├── .gitignore ├── LICENSE ├── README.md ├── deps.edn ├── docs └── tools_decompiler_slides.pdf ├── java └── clojure │ └── tools │ └── decompiler │ └── RetrieveClasses.java ├── project.clj └── src ├── clojure └── tools │ ├── decompiler.clj │ └── decompiler │ ├── ast.clj │ ├── bc.clj │ ├── compact.clj │ ├── pprint.clj │ ├── source.clj │ ├── sugar.clj │ └── utils.clj └── data_readers.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | /.lein-* 8 | /.nrepl-port 9 | .hgignore 10 | .hg/ 11 | .cpcache/ 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor to control, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | I gave a talk on tools.decompiler at Clojure/Conj in October 2017. Video [here](https://www.youtube.com/watch?v=2SGFeegEt9E) 2 | 3 | # Dependencies: 4 | 5 | Leiningen: 6 | ```clojure 7 | [bronsa/tools.decompiler "0.1.0-alpha1"] 8 | ``` 9 | 10 | # Usage: 11 | 12 | Use `lein javac` to AOT compile `clojure.tools.decompiler.RetrieveClasses` then you can use `lein repl` or `clj` to launch a repl 13 | 14 | Use `decompile-classfiles `to decompile AOT compiled classes: 15 | 16 | ```clojure 17 | user=> (require '[clojure.tools.decompiler :as d]) 18 | nil 19 | user=> (d/decompile-classfiles {:input-path "path/to/root/classes/directory" :output-path "path/to/src"}) 20 | ;; with no :output-path, decompile to stdout 21 | [...] 22 | ``` 23 | 24 | You can use `decompile-classes` to decompile in memory classes, but to do so you must start the JVM using the java agent provided with `tools.decompiler` (use e.g. `lein jar` to build the jar): 25 | 26 | ```clojure 27 | [~/src/tools.decompiler] clj -J-javaagent:tools.decompiler.jar 28 | user=> (require '[clojure.tools.decompiler :as d]) 29 | nil 30 | user=> (defn foo [a] a) 31 | #'user/foo 32 | user=> (decompile-classes {:classes #{"user$foo"}}) ;; optionally :output-path to decompile to disk 33 | Decompiling user$foo 34 | (fn foo 35 | ([a] a) 36 | nil 37 | ``` 38 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:deps {org.clojure/clojure {:mvn/version "1.10.0"} 2 | org.clojure/core.match {:mvn/version "0.3.0-alpha5"} 3 | org.apache.bcel/bcel {:mvn/version "6.1"} 4 | fipp {:mvn/version "0.6.26"}} 5 | :paths ["src" "target/classes"]} 6 | -------------------------------------------------------------------------------- /docs/tools_decompiler_slides.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bronsa/tools.decompiler/51f222ed7db0049f27ebee3c3071672d516a6b5e/docs/tools_decompiler_slides.pdf -------------------------------------------------------------------------------- /java/clojure/tools/decompiler/RetrieveClasses.java: -------------------------------------------------------------------------------- 1 | // Copyright (c) Nicola Mometto & contributors. 2 | // The use and distribution terms for this software are covered by the 3 | // Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | // which can be found in the file epl-v10.html at the root of this distribution. 5 | // By using this software in any fashion, you are agreeing to be bound by 6 | // the terms of this license. 7 | // You must not remove this notice, or any other, from this software. 8 | 9 | package clojure.tools.decompiler; 10 | 11 | import java.lang.instrument.Instrumentation; 12 | import java.lang.instrument.ClassFileTransformer; 13 | import java.lang.instrument.IllegalClassFormatException; 14 | import java.security.ProtectionDomain; 15 | 16 | import java.util.Map; 17 | import java.util.concurrent.ConcurrentHashMap; 18 | 19 | public class RetrieveClasses { 20 | 21 | private static Map classes = new ConcurrentHashMap(); 22 | 23 | public static Map getClasses() { 24 | return classes; 25 | } 26 | 27 | public static class Transformer implements ClassFileTransformer { 28 | public byte[] transform(ClassLoader loader, String className, 29 | Class classBeingRedefined, ProtectionDomain protectionDomain, 30 | byte[] classBytes) throws IllegalClassFormatException { 31 | classes.put(className, classBytes); 32 | return classBytes; 33 | } 34 | } 35 | 36 | public static void premain(String args, Instrumentation inst) { 37 | inst.addTransformer(new Transformer()); 38 | } 39 | 40 | } 41 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject bronsa/tools.decompiler "0.1.0-alpha1" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :java-source-paths ["java"] 7 | :manifest {"Premain-Class" "clojure.tools.decompiler.RetrieveClasses"} 8 | :dependencies [[org.clojure/clojure "1.10.0"] 9 | [org.clojure/core.match "0.3.0-alpha5"] 10 | [org.apache.bcel/bcel "6.1"] 11 | [fipp "0.6.12"]]) 12 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler 10 | (:require [clojure.java.io :as io] 11 | [clojure.string :as s] 12 | [clojure.tools.decompiler.bc :as bc] 13 | [clojure.tools.decompiler.ast :as ast] 14 | [clojure.tools.decompiler.sugar :as sa] 15 | [clojure.tools.decompiler.source :as src] 16 | [clojure.tools.decompiler.compact :as cmp] 17 | [clojure.tools.decompiler.pprint :as pp])) 18 | 19 | (defn absolute-filename [filename] 20 | (-> filename 21 | (io/file) 22 | (.getAbsolutePath))) 23 | 24 | (defn class->source [classfile-or-classname bc-for lenient?] 25 | (-> classfile-or-classname 26 | (bc/analyze-class) 27 | (ast/bc->ast {:bc-for bc-for :lenient? lenient?}) 28 | (sa/ast->sugared-ast) 29 | (src/ast->clj) 30 | (cmp/macrocompact) 31 | (pp/pprint))) 32 | 33 | (defn cname [c input-path] 34 | (-> c 35 | (subs 0 (- (count c) (count ".class"))) 36 | (subs (inc (count input-path))))) 37 | 38 | (defn classfile? [^String f] 39 | (.endsWith f ".class")) 40 | 41 | (defn bc-for [classname->path] 42 | (fn [classname] 43 | (some-> classname 44 | (s/replace "." "/") 45 | classname->path 46 | absolute-filename 47 | bc/analyze-class))) 48 | 49 | (defn decompile-classfiles [{:keys [input-path output-path ?only-classes lenient?]}] 50 | (let [files (filter classfile? (map str (file-seq (io/file input-path)))) 51 | classname->path (into {} (map (fn [^String classfile] 52 | [(cname classfile input-path) classfile]) 53 | files)) 54 | inits (if ?only-classes 55 | (mapv classname->path ?only-classes) 56 | (filter (fn [^String i] (.endsWith i "__init.class")) files))] 57 | 58 | (doseq [init inits] 59 | (let [cname (cname init input-path) 60 | ns-name (subs cname 0 (- (count cname) (count "__init"))) 61 | ns-file (str output-path "/" (s/replace ns-name "." "/") ".clj")] 62 | (println (str "Decompiling " init (when output-path (str " to " ns-file)))) 63 | (let [source (class->source (absolute-filename init) (bc-for classname->path) lenient?)] 64 | (if output-path 65 | (do (io/make-parents ns-file) 66 | (spit ns-file source)) 67 | (println source))))))) 68 | 69 | (defn decompile-classes [{:keys [classes lenient?] :or {lenient? true}}] 70 | (doseq [class classes] 71 | (println "Decompiling" class) 72 | (let [source (class->source (s/replace class "." "/") 73 | (fn [^String classname] 74 | (when-not (.startsWith classname "clojure.lang.") 75 | (bc/analyze-class (s/replace classname "." "/")))) 76 | lenient?)] 77 | (println source)))) 78 | 79 | (comment 80 | (decompile-classfiles 81 | {:input-path "classes/" 82 | :output-path "src/" 83 | :?only-classes ["my/ns__init"] 84 | :lenient? true})) 85 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/ast.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.ast 10 | (:require [clojure.set :as set] 11 | [clojure.string :as s] 12 | [clojure.tools.decompiler.bc :as bc] 13 | [clojure.tools.decompiler.utils :refer [peek-n pop-n] :as u])) 14 | 15 | ;; WIP casting, type hints 16 | 17 | (declare bc->ast) 18 | 19 | (def initial-ctx {:fields {} 20 | :statements [] 21 | :ast {}}) 22 | 23 | (def initial-local-ctx {:stack [] 24 | :pc 0 25 | :impure-loops #{} ;; loops with no bindings, pure jumps 26 | :local-variable-table #{} 27 | :exception-table #{} 28 | :reachable #{}}) 29 | 30 | (defn pc= [terminate-at] 31 | (fn [{:keys [pc]}] 32 | (= pc terminate-at))) 33 | 34 | (defn goto-label [{:insn/keys [jump-offset label]}] 35 | (+ jump-offset label)) 36 | 37 | (def nil-expr {:op :const :val nil}) 38 | 39 | (defn ->do [exprs] 40 | {:op :do 41 | :statements (vec (remove #{nil-expr} (butlast exprs))) 42 | :ret (or (last exprs) nil-expr)}) 43 | 44 | (defn expr+statements [ctx] 45 | (->do (conj (-> ctx :statements) 46 | (-> ctx :stack peek)))) 47 | 48 | (defn curr-insn [{:keys [insns jump-table pc]}] 49 | (->> pc 50 | (get jump-table) 51 | (nth insns))) 52 | 53 | (defn insn-at [{:keys [insns jump-table pc]} {:keys [label offset] :or {label pc offset 0}}] 54 | (->> label 55 | (get jump-table) 56 | (+ offset) 57 | (nth insns))) 58 | 59 | (defn maybe-insn-at [{:keys [insns jump-table pc]} {:keys [label offset] :or {label pc offset 0}}] 60 | (some->> label 61 | (get jump-table) 62 | (+ offset) 63 | (get insns))) 64 | 65 | (defn find-local-variable [{:keys [local-variable-table]} index label] 66 | (->> local-variable-table 67 | (filter (comp #{index} :index)) 68 | (filter (comp (partial >= label) :start-label)) 69 | (filter (comp (partial < label) :end-label)) 70 | (sort-by :start-label) 71 | (first))) 72 | 73 | (defn find-init-local [{:keys [local-variable-table]} label] 74 | (->> local-variable-table 75 | (filter (comp (partial = label) :start-label)) 76 | ;; why is this here? 77 | (filter (comp (partial < label) :end-label)) 78 | (sort-by :start-label) 79 | (first))) 80 | 81 | (defn find-no-op-local-init [{:keys [local-variable-table]} index label] 82 | (->> local-variable-table 83 | (filter (comp #{index} :index)) 84 | (filter (comp #{label} :start-label)) 85 | (filter (comp #{label} :end-label)) 86 | (sort-by :start-label) 87 | (first))) 88 | 89 | (defn init-local-variable? [{:insn/keys [label length]} {:keys [start-label]}] 90 | (= (+ label length) start-label)) 91 | 92 | ;; process-* : bc, ctx -> ctx 93 | ;; decompile-* : bc, ctx -> AST 94 | 95 | (defn restrict [x y] 96 | (if x (some-fn x y) y)) 97 | 98 | (defn get-reachable [pc reachable {:keys [insns jump-table] :as ctx}] 99 | (if (or ;; we're exiting 100 | (not (get jump-table pc)) 101 | ;; we've already visited this node 102 | (contains? reachable pc)) 103 | reachable 104 | (let [insn (curr-insn (assoc ctx :pc pc)) 105 | reachable (conj reachable pc) 106 | insn-name (:insn/name insn)] 107 | (cond 108 | 109 | (= insn-name "goto") 110 | (recur (+ pc (:insn/jump-offset insn)) reachable ctx) 111 | 112 | (= insn-name "athrow") 113 | (recur -1 reachable ctx) 114 | 115 | (contains? #{"ifeq" "ifnull" "ifle" "ifge" "ifne" "iflt" "ifgt" 116 | "if_icmpeq""if_icmpne" "if_icmpgt" "if_icmpge" "if_icmple" "if_icmplt" 117 | "if_acmpne" "if_acmpeq"} 118 | insn-name) 119 | (let [reachable (get-reachable (+ pc (:insn/length insn)) reachable ctx)] 120 | (recur (+ pc (:insn/jump-offset insn)) reachable ctx)) 121 | 122 | :else (recur (+ pc (:insn/length insn)) reachable ctx))))) 123 | 124 | (defn collect-reachable [ctx] 125 | (let [reachable (get-reachable 0 #{} ctx)] 126 | (assoc ctx :reachable reachable))) 127 | 128 | (def process-insn nil) 129 | (defmulti process-insn 130 | (fn [_ {:insn/keys [name]}] (keyword name)) 131 | :hierarchy #'bc/insn-h) 132 | 133 | (defmethod process-insn :default [ctx {:insn/keys [name]}] 134 | (println "INSN NOT HANDLED:" name) 135 | (throw (Exception. ":(")) 136 | ctx) 137 | 138 | (defn start-try-block-info [pc exception-table] 139 | (seq (filter (comp #{pc} :start-label) exception-table))) 140 | 141 | (defn >process-insn [{:keys [pc] :as ctx} {:insn/keys [length] :as insn}] 142 | (-> (process-insn ctx insn) 143 | (update :pc (fn [new-pc] 144 | (if (= new-pc pc) 145 | ;; last insn wasn't an explicit jump, goto next insn 146 | (+ new-pc length) 147 | new-pc))))) 148 | 149 | (declare process-insns) 150 | 151 | (defn process-try-block [{:keys [pc exception-table] :as ctx}] 152 | (let [handlers (->> (start-try-block-info pc exception-table) 153 | (sort-by (comp - :end-label)) 154 | (partition-by :end-label) 155 | (first)) 156 | 157 | first-handler (->> handlers (sort-by :handler-label) first) 158 | 159 | body-end-label (:end-label first-handler) 160 | 161 | ret-label (-> (insn-at ctx {:label (:handler-label first-handler) 162 | :offset -1}) 163 | 164 | (goto-label) 165 | (as-> % 166 | (:insn/label (insn-at ctx {:label % :offset 1})))) 167 | 168 | expr-ctx (-> ctx 169 | (update :exception-table #(apply disj % handlers))) 170 | 171 | ;; WIP: need to backup lvt? 172 | body-ctx (-> expr-ctx 173 | (assoc :statements []) 174 | (assoc :terminate? (restrict (:terminate? expr-ctx) (pc= body-end-label))) 175 | (process-insns)) 176 | 177 | body (->do (conj (-> body-ctx :statements) (-> body-ctx :stack peek))) 178 | 179 | next-insn (insn-at body-ctx {:offset 1}) 180 | 181 | ?finally (when (seq (remove :type handlers)) 182 | (let [start-label (:insn/label next-insn) 183 | end-label (:insn/label (insn-at ctx {:label (:handler-label first-handler) :offset -1})) 184 | finally-ctx (process-insns (-> expr-ctx 185 | (assoc :pc start-label) 186 | (assoc :statements []) 187 | (assoc :terminate? (restrict (:terminate? expr-ctx ) (pc= end-label)))))] 188 | (->do (-> finally-ctx :statements)))) 189 | 190 | ?catches (when-let [catches (seq (filter :type handlers))] 191 | (->> 192 | (for [{:keys [handler-label type]} catches 193 | :let [{:keys [start-label end-label name] :as local} (find-init-local ctx handler-label)]] 194 | (let [end-label (:insn/label (insn-at ctx {:label end-label :offset -1})) 195 | catch-ctx (process-insns (-> expr-ctx 196 | (assoc :pc start-label) 197 | (assoc :exception-table #{}) 198 | (update :stack conj local) 199 | (assoc :statements []) 200 | (assoc :terminate? (restrict (:terminate? expr-ctx) (pc= end-label)))))] 201 | {:op :catch 202 | :local {:name name 203 | :type type} 204 | :body (->do (conj (-> catch-ctx :statements) 205 | (-> catch-ctx :stack peek)))})) 206 | (into []))) 207 | 208 | expr (if (or ?finally 209 | (seq ?catches)) 210 | {:op :try 211 | :catches ?catches 212 | :finally ?finally 213 | :body body} 214 | body)] 215 | 216 | (-> ctx 217 | (update :stack conj expr) 218 | (assoc :recur? (:recur? body-ctx)) 219 | (assoc :pc ret-label)))) 220 | 221 | ;; doesn't handle wrapping try/catch/finally 222 | (defn will-ret? [ctx label] 223 | (loop [off 0] 224 | (let [{:insn/keys [name] :as insn} (maybe-insn-at ctx {:label label :offset off})] 225 | (cond 226 | (not insn) 227 | true 228 | 229 | (or (#{"invokestatic" "checkcast"} name) 230 | (isa? bc/insn-h (keyword name) ::bc/no-op) 231 | (isa? bc/insn-h (keyword name) ::bc/return-value) 232 | (isa? bc/insn-h (keyword name) ::bc/invoke-instance-method)) 233 | (recur (inc off)) 234 | 235 | :else 236 | 237 | false)))) 238 | 239 | (defn process-impure-loop [{:keys [impure-loops pc] :as ctx}] 240 | (let [end-label (impure-loops pc) 241 | 242 | {body-stack :stack body-stmnts :statements :keys [pc]} (process-insns (-> ctx 243 | (assoc :loop-args []) 244 | (update :impure-loops disj pc) 245 | (assoc :loop-end-label end-label) 246 | (assoc :terminate? (restrict (:terminate? ctx) :recur?)) 247 | (assoc :statements []))) 248 | statement? (not (will-ret? ctx end-label)) 249 | body (->do (conj body-stmnts (peek body-stack)))] 250 | (-> ctx 251 | (assoc :pc pc) 252 | (update (if statement? :statements :stack) 253 | conj {:op :loop 254 | :local-variables [] 255 | :body body})))) 256 | 257 | (defn process-insns [{:keys [pc jump-table exception-table terminate? impure-loops] 258 | :as ctx}] 259 | (cond 260 | (or (not (get jump-table pc)) 261 | (and terminate? (terminate? ctx))) 262 | ctx 263 | 264 | (start-try-block-info pc exception-table) 265 | (recur (process-try-block ctx)) 266 | 267 | (contains? impure-loops pc) 268 | (recur (process-impure-loop ctx)) 269 | 270 | :else 271 | (let [insn (curr-insn ctx)] 272 | (recur (>process-insn ctx insn))))) 273 | 274 | (defmethod process-insn ::bc/no-op [ctx _] 275 | ctx) 276 | 277 | (defmethod process-insn ::bc/const-insn [ctx {:insn/keys [pool-element]}] 278 | (-> ctx 279 | (update :stack conj {:op :const 280 | :val (:insn/target-value pool-element)}))) 281 | 282 | (defmethod process-insn :swap [{:keys [stack] :as ctx} _] 283 | (let [[v2 v1] (peek-n stack 2)] 284 | (-> ctx 285 | (update :stack pop-n 2) 286 | (update :stack conj v1 v2)))) 287 | 288 | (defmethod process-insn :dup_x1 [{:keys [stack] :as ctx} _] 289 | (let [[v2 v1] (peek-n stack 2)] 290 | (-> ctx 291 | (update :stack pop-n 2) 292 | (update :stack conj v1 v2 v1)))) 293 | 294 | (defmethod process-insn :dup [{:keys [stack] :as ctx} _] 295 | (let [val (peek stack)] 296 | (-> ctx 297 | (update :stack conj val)))) 298 | 299 | (defmethod process-insn :anewarray [{:keys [stack] :as ctx} _] 300 | (let [{dimension :val} (peek stack) 301 | expr {:op :array 302 | :!items (atom (vec (repeat dimension nil-expr)))}] 303 | 304 | (-> ctx 305 | (update :stack pop) 306 | (update :stack conj expr)))) 307 | 308 | (defmethod process-insn ::bc/array-store [{:keys [stack] :as ctx} _] 309 | (let [[{:keys [!items]} {index :val} value] (peek-n stack 3)] 310 | (swap! !items assoc index value) 311 | (-> ctx 312 | (update :stack pop-n 3)))) 313 | 314 | (defmethod process-insn :monitorenter [{:keys [stack] :as ctx} _] 315 | (let [sentinel (peek stack)] 316 | (-> ctx 317 | (update :stack pop) 318 | (update :statements conj {:op :monitor-enter 319 | :sentinel sentinel})))) 320 | 321 | (defmethod process-insn :monitorexit [{:keys [stack] :as ctx} _] 322 | (let [sentinel (peek stack)] 323 | (-> ctx 324 | (update :stack pop) 325 | (update :statements conj {:op :monitor-exit 326 | :sentinel sentinel})))) 327 | 328 | (defmethod process-insn :return [{:keys [stack statements] :as ctx} _] 329 | (let [ret (peek stack)] 330 | (-> ctx 331 | (assoc :ast (->do (conj statements ret)))))) 332 | 333 | (defmethod process-insn ::bc/return-value [{:keys [stack statements] :as ctx} _] 334 | (let [ret (peek stack)] 335 | (-> ctx 336 | (assoc :stack [] :statements [] 337 | :ast (->do (conj statements ret)))))) 338 | 339 | (defn process-if [{:keys [stack] :as ctx} test [start-then end-then] 340 | [start-else end-else maybe-one-armed?]] 341 | (let [then-ctx (process-insns (assoc ctx 342 | :pc start-then 343 | :terminate? (restrict (:terminate? ctx) (pc= end-then)) 344 | :statements [])) 345 | 346 | one-armed? (and (not (:recur? then-ctx)) maybe-one-armed?) 347 | 348 | end-else (if (and maybe-one-armed? (not one-armed?)) 349 | (:loop-end-label ctx) 350 | end-else) 351 | 352 | else-ctx (when-not one-armed? 353 | (process-insns (assoc ctx 354 | :pc start-else 355 | :terminate? (restrict (:terminate? ctx) (pc= end-else)) 356 | :statements []))) 357 | 358 | {then-stack :stack then-stmnts :statements then-recur? :recur?} then-ctx 359 | {else-stack :stack else-stmnts :statements else-recur? :recur?} else-ctx 360 | 361 | statement? (or one-armed? (= stack then-stack else-stack)) 362 | 363 | [then else] (if statement? 364 | [then-stmnts else-stmnts] 365 | [(conj then-stmnts (peek then-stack)) 366 | (conj else-stmnts (peek else-stack))])] 367 | (-> ctx 368 | (assoc :pc end-else) 369 | (update (if statement? :statements :stack) 370 | conj {:op :if 371 | :test test 372 | :then (->do then) 373 | :else (if else (->do else) nil-expr)}) 374 | (cond-> (not statement?) 375 | (assoc :recur? (or then-recur? else-recur?)) 376 | one-armed? (assoc :pc start-else))))) 377 | 378 | (defmethod process-insn :ifnull [{:keys [stack] :as ctx} insn] 379 | (let [null-label (goto-label insn) 380 | goto-end-insn (insn-at ctx {:label null-label :offset -1}) 381 | 382 | goto-else-insn (insn-at ctx {:offset 2}) 383 | else-label (goto-label goto-else-insn) 384 | 385 | {then-label :insn/label} (insn-at ctx {:offset 3}) 386 | 387 | [test _] (peek-n stack 2) 388 | 389 | maybe-one-armed? (not (:insn/jump-offset goto-end-insn)) 390 | end-label (if maybe-one-armed? 391 | (reduce max 0 (keys (:jump-table ctx))) 392 | (goto-label goto-end-insn))] 393 | (-> ctx 394 | (update :stack pop-n 2) 395 | (process-if test [then-label (:insn/label goto-end-insn)] [else-label end-label maybe-one-armed?])))) 396 | 397 | 398 | (defmethod process-insn :ifeq [{:keys [stack] :as ctx} insn] 399 | (let [else-label (goto-label insn)] 400 | (if (and (= else-label (:insn/label (insn-at ctx {:offset 3}))) 401 | (= ((juxt :insn/name :insn/pool-element) (insn-at ctx {:offset 3})) 402 | ["getstatic" #:insn{:target-class "java.lang.Boolean", 403 | :target-name "FALSE", 404 | :target-type "java.lang.Boolean"}])) 405 | (-> ctx 406 | (assoc :pc (:insn/label (insn-at ctx {:offset 4})))) 407 | (let [goto-end-insn (insn-at ctx {:label else-label :offset -2}) 408 | {then-label :insn/label} (insn-at ctx {:offset 1}) 409 | test (peek stack) 410 | maybe-one-armed? (not (:insn/jump-offset goto-end-insn)) 411 | end-label (if maybe-one-armed? 412 | (reduce max 0 (keys (:jump-table ctx))) 413 | (goto-label goto-end-insn))] 414 | (-> ctx 415 | (update :stack pop) 416 | (process-if test [then-label (:insn/label goto-end-insn)] [else-label end-label maybe-one-armed?])))))) 417 | 418 | (defmethod process-insn ::bc/aget [{:keys [stack] :as ctx} _] 419 | (let [[arr i] (peek-n stack 2)] 420 | (-> ctx 421 | (update :stack pop-n 2) 422 | (update :stack conj {:op :invoke 423 | :fn {:op :var :ns "clojure.core" :name "aget"} 424 | :args [arr i]})))) 425 | 426 | (defmethod process-insn :arraylength [{:keys [stack] :as ctx} _] 427 | (let [arr (peek stack)] 428 | (-> ctx 429 | (update :stack pop) 430 | (update :stack conj {:op :invoke 431 | :fn {:op :var :ns "clojure.core" :name "alength"} 432 | :args [arr]})))) 433 | 434 | (defmethod process-insn ::bc/number-compare [{:keys [stack] :as ctx} insn] 435 | (let [offset (if (= "if_icmpne" (:insn/name insn)) 0 1) 436 | insn (insn-at ctx {:offset offset}) 437 | 438 | op (case (:insn/name insn) 439 | "ifle" ">" 440 | "ifge" "<" 441 | "ifne" "=" 442 | "iflt" ">=" 443 | "ifgt" "<=" 444 | "if_icmpne" "=") 445 | 446 | else-label (goto-label insn) 447 | 448 | goto-end-insn (insn-at ctx {:label else-label :offset -2}) 449 | 450 | {then-label :insn/label} (insn-at ctx {:offset (inc offset)}) 451 | 452 | [a b] (peek-n stack 2) 453 | 454 | test {:op :invoke :fn {:op :var :ns "clojure.core" :name op} :args [a b]} 455 | 456 | maybe-one-armed? (not (:insn/jump-offset goto-end-insn)) 457 | end-label (if maybe-one-armed? 458 | (reduce max 0 (keys (:jump-table ctx))) 459 | (goto-label goto-end-insn))] 460 | (-> ctx 461 | (update :stack pop-n 2) 462 | (process-if test [then-label (:insn/label goto-end-insn)] [else-label end-label maybe-one-armed?])))) 463 | 464 | (defmethod process-insn :goto [{:keys [loop-args] :as ctx} {:insn/keys [jump-offset]}] 465 | (if-not (pos? jump-offset) 466 | (let [args (for [{:keys [start-label index]} loop-args 467 | :let [{:keys [init]} (find-local-variable ctx index start-label)]] 468 | init)] 469 | (-> ctx 470 | (assoc :recur? true) 471 | (update :stack conj {:op :recur 472 | :args (vec args)}))) 473 | ;; case || proto inline cache 474 | (-> ctx 475 | (update :pc + jump-offset)))) 476 | 477 | (defn skip-locals-clearing-lv [ctx] 478 | (if (and (= "aconst_null" (:insn/name (insn-at ctx {:offset 1}))) 479 | (isa? bc/insn-h (-> (insn-at ctx {:offset 2}) :insn/name keyword) ::bc/store-insn) 480 | (= (-> (curr-insn ctx) :insn/local-variable-element :insn/target-index) 481 | (-> (insn-at ctx {:offset 2}) :insn/local-variable-element :insn/target-index))) 482 | (-> ctx 483 | (assoc :pc (:insn/label (insn-at ctx {:offset 3})))) 484 | ctx)) 485 | 486 | (defmethod process-insn ::bc/load-insn [{:keys [closed-overs] :as ctx} {:insn/keys [local-variable-element label]}] 487 | (let [{:insn/keys [target-index]} local-variable-element] 488 | (if-let [local (find-local-variable ctx target-index label)] 489 | (-> ctx 490 | (update :stack conj local) 491 | (skip-locals-clearing-lv)) 492 | (if (contains? closed-overs target-index) 493 | (-> ctx 494 | (update :stack conj {:op :closed-over 495 | :target target-index}) 496 | (skip-locals-clearing-lv)) 497 | (throw (Exception. ":(")))))) 498 | 499 | (defn find-recur-jump-label [{:keys [jump-table pc insns] :as ctx} {:keys [start-label end-label index]}] 500 | (loop [[{:insn/keys [name length label local-variable-element] :as insn} & insns] (drop (inc (get jump-table pc)) insns)] 501 | 502 | (cond 503 | 504 | (or (nil? insn) 505 | (> label end-label)) 506 | false 507 | 508 | (and (isa? bc/insn-h (keyword name) ::bc/store-insn) 509 | (= (:insn/target-index local-variable-element) index) 510 | (= (:start-label (find-local-variable ctx index label)) start-label) 511 | (= "goto" (:insn/name (first insns))) 512 | (neg? (:insn/jump-offset (first insns))) 513 | (< (goto-label (first insns)) end-label)) 514 | (+ label length) 515 | 516 | :else 517 | (recur insns)))) 518 | 519 | (defn find-loop-info [{:keys [local-variable-table] :as ctx} {:keys [start-label end-label] :as insn}] 520 | (when-let [jump-label (find-recur-jump-label ctx insn)] 521 | (let [insn (insn-at ctx {:label jump-label}) 522 | loop-label (goto-label insn)] 523 | {:loop-label loop-label 524 | :loop-args (->> (for [local-variable local-variable-table 525 | :when (and (= (:end-label local-variable) end-label) 526 | (>= loop-label (:start-label local-variable) start-label))] 527 | local-variable) 528 | (sort-by :start-label) 529 | (into []))}))) 530 | 531 | (defn process-loop [ctx {:keys [loop-label loop-args]} {:keys [end-label] :as local-variable} init] 532 | (let [{:insn/keys [length]} (curr-insn ctx)] 533 | (loop [[arg & loop-args] (rest loop-args) 534 | args-ctx (-> ctx (update :pc + length)) 535 | args [{:op :local-variable :local-variable local-variable :init init}]] 536 | (if arg 537 | (let [pre-insn (insn-at ctx {:label (:start-label arg) :offset -1}) ;; astore 538 | {:keys [statements stack] :as new-ctx} (process-insns (-> args-ctx 539 | (assoc :terminate? (restrict (:terminate? ctx) (pc= (:insn/label pre-insn)))) 540 | (assoc :statements []))) 541 | 542 | local-variable (find-init-local new-ctx (:start-label arg)) 543 | init (if (seq statements) (->do (conj statements (peek stack))) (peek stack))] 544 | (recur loop-args 545 | (-> new-ctx 546 | (update :pc + (:insn/length pre-insn)) 547 | (update :local-variable-table disj local-variable) 548 | (update :local-variable-table conj (assoc local-variable :init init))) 549 | (conj args {:op :local-variable :local-variable local-variable :init init}))) 550 | 551 | (let [{body-stack :stack body-stmnts :statements} (process-insns (-> ctx 552 | (assoc :local-variable (:local-variable args-ctx)) 553 | (assoc :pc loop-label) 554 | (assoc :loop-args (mapv :local-variable args)) 555 | (assoc :loop-end-label end-label) 556 | (assoc :terminate? (restrict (:terminate? ctx) (pc= end-label))) 557 | (assoc :statements []))) 558 | 559 | statement? (not (will-ret? ctx end-label)) 560 | body (->do (conj body-stmnts (peek body-stack)))] 561 | (-> ctx 562 | (assoc :pc end-label) 563 | (update (if statement? :statements :stack) 564 | conj {:op :loop 565 | :local-variables args 566 | :body body}))))))) 567 | 568 | (defn process-let [{:keys [stack] :as ctx} {:keys [end-label] :as local-variable} init] 569 | (let [{:insn/keys [length]} (curr-insn ctx) 570 | body-ctx (process-insns (-> ctx 571 | (update :pc + length) 572 | (assoc :terminate? (restrict (:terminate? ctx) (pc= end-label))) 573 | (assoc :statements []))) 574 | {body-stack :stack body-stmnts :statements :keys [recur?]} body-ctx 575 | statement? (= stack body-stack) 576 | body (->do (if statement? body-stmnts (conj body-stmnts (peek body-stack))))] 577 | (-> ctx 578 | (assoc :pc end-label) 579 | (update (if statement? :statements :stack) 580 | conj {:op :let 581 | :local-variables [{:op :local-variable 582 | :local-variable local-variable 583 | :init init}] 584 | :body body}) 585 | (cond-> (not statement?) 586 | (assoc :recur? recur?))))) 587 | 588 | (defn process-letfn [{:keys [local-variable-table pc bc-for lenient?] :as ctx} target-index] 589 | (let [{:keys [index start-label end-label]} (->> local-variable-table 590 | (filter (comp (partial < pc) :start-label)) 591 | (sort-by :index) 592 | first)] 593 | 594 | (if (= target-index index) 595 | (let [local-variables (->> local-variable-table 596 | (filter (comp #{start-label} :start-label)) 597 | (sort-by :index)) 598 | letfn-fns (loop [pc pc fns []] 599 | (let [insn (curr-insn (assoc ctx :pc pc))] 600 | (cond 601 | (= (count fns) (count local-variables)) 602 | fns 603 | 604 | (= "new" (:insn/name insn)) 605 | (recur (+ pc (:insn/length insn)) 606 | (conj fns (-> insn :insn/pool-element :insn/target-value))) 607 | 608 | :else 609 | (recur (+ pc (:insn/length insn)) fns)))) 610 | 611 | init-local-variables (map (fn [lv fn] 612 | (let [init (bc->ast (bc-for fn) 613 | {:bc-for bc-for 614 | :lenient? lenient? 615 | :fn-name (:name lv)})] 616 | (assoc lv :init init))) 617 | local-variables letfn-fns) 618 | {:keys [stack] :as ctx} (update ctx :stack pop) 619 | body-ctx (-> ctx 620 | (assoc :statements []) 621 | (update :local-variable-table #(apply disj % local-variables)) 622 | (update :local-variable-table #(apply conj % init-local-variables)) 623 | (assoc :pc start-label) 624 | (assoc :terminate? (restrict (:terminate? ctx) (pc= end-label))) 625 | (process-insns)) 626 | {body-stack :stack body-stmnts :statements :keys [recur?]} body-ctx 627 | statement? (= stack body-stack) 628 | body (->do (if statement? body-stmnts (conj body-stmnts (peek body-stack))))] 629 | (-> ctx 630 | (assoc :pc end-label) 631 | (update (if statement? :statements :stack) 632 | conj {:op :letfn 633 | :local-variables (mapv (fn [{:keys [init] :as lv}] 634 | {:op :local-variable 635 | :local-variable (dissoc lv :init) 636 | :init init}) 637 | init-local-variables) 638 | :body body}) 639 | (cond-> (not statement?) 640 | (assoc :recur? recur?)))) 641 | (throw (Exception. ":("))))) 642 | 643 | (defn process-lexical-block [ctx local-variable init] 644 | (if-let [loop-info (find-loop-info ctx local-variable)] 645 | (process-loop ctx loop-info local-variable init) 646 | (process-let ctx local-variable init))) 647 | 648 | (defmethod process-insn ::bc/pop [{:keys [stack] :as ctx} {:insn/keys [label length]}] 649 | (if-let [statement (peek stack)] 650 | (if-let [local-variable (find-init-local ctx (+ label length))] 651 | (-> ctx 652 | (update :stack pop) 653 | (update :local-variable-table disj local-variable) 654 | (update :local-variable-table conj (assoc local-variable :init statement)) 655 | (process-lexical-block local-variable statement)) 656 | (-> ctx 657 | (update :stack pop) 658 | (update :statements conj statement))) 659 | ctx)) 660 | 661 | (defmethod process-insn ::bc/store-insn [{:keys [stack] :as ctx} {:insn/keys [local-variable-element label length] :as insn}] 662 | (let [{:insn/keys [target-index]} local-variable-element] 663 | (if-let [local-variable (find-local-variable ctx target-index (+ label length))] 664 | (let [init (peek stack) 665 | initialized-local-variable (assoc local-variable :init init) 666 | ctx (-> ctx 667 | (update :stack pop) 668 | (update :local-variable-table disj local-variable) 669 | (update :local-variable-table conj initialized-local-variable))] 670 | (if (init-local-variable? insn local-variable) 671 | (process-lexical-block ctx local-variable init) 672 | ctx)) 673 | (if (find-no-op-local-init ctx target-index (+ label length)) 674 | (let [init (peek stack)] 675 | (-> ctx 676 | (update :stack pop) 677 | (update :statements conj init))) 678 | (process-letfn ctx target-index))))) 679 | 680 | (defn parse-collision-expr [exprs {:keys [test then else]}] 681 | (let [node [(-> test :args first) then] 682 | exprs (conj exprs node)] 683 | (if (= :if (-> else :ret :op)) 684 | (recur exprs (:ret else)) 685 | exprs))) 686 | 687 | (defmethod process-insn ::bc/select [{:keys [stack] :as ctx} {:insn/keys [jump-targets label] :as insn}] 688 | (let [{:insn/keys [jump-offsets default-offset jump-matches]} jump-targets 689 | 690 | test (peek stack) 691 | 692 | shift+mask? (= :invoke (:op test)) 693 | ?shift (when shift+mask? 694 | (-> test :args first :args second :val)) 695 | ?mask (when shift+mask? 696 | (-> test :args second :val)) 697 | test (cond-> test shift+mask? (-> :args first :args first)) 698 | 699 | hash-test? (= :invoke-static (:op test)) 700 | test (cond-> test hash-test? (-> :args first)) 701 | 702 | jump-labels (mapv (partial + label) jump-offsets) 703 | 704 | default-label (+ default-offset label) 705 | 706 | 707 | label-match (->> (for [i (range (count jump-labels)) 708 | :let [label (nth jump-labels i) 709 | match (nth jump-matches i)] 710 | :when (not= label default-label)] 711 | [label match]) 712 | (into [])) 713 | 714 | ;; WIP: extract & refactor 715 | exprs (->> (for [i (range (count label-match)) 716 | :let [[label match] (nth label-match i) 717 | [next-label] (nth (conj label-match [default-label nil]) (inc i)) 718 | end-label (:insn/label (insn-at ctx {:label next-label :offset -1}))]] 719 | 720 | (if hash-test? 721 | (if (= "getstatic" (:insn/name (insn-at ctx {:label label}))) 722 | (let [test-ctx (-> ctx 723 | (assoc :pc label 724 | :statements [] 725 | :terminate? (restrict (:terminate? ctx) (pc= end-label))) 726 | (process-insns)) 727 | test (expr+statements test-ctx) 728 | exprs (-> test :ret :body :ret :body :ret)] 729 | [:collision match (parse-collision-expr [] exprs) test (:recur? test-ctx)]) 730 | 731 | (let [{:keys [stack] :as test-ctx} (-> ctx 732 | (assoc :pc label 733 | :statements [] 734 | :terminate? (restrict (:terminate? ctx) 735 | (fn [ctx] 736 | (#{"if_acmpne" "invokestatic"} 737 | (:insn/name (curr-insn ctx)))))) 738 | (process-insns)) 739 | test (peek stack) 740 | hash-identity? (= "if_acmpne" (:insn/name (curr-insn test-ctx))) 741 | start-expr-label (if hash-identity? 742 | (:insn/label (insn-at test-ctx {:offset 1})) 743 | (:insn/label (insn-at test-ctx {:offset 2}))) 744 | expr-ctx (-> ctx 745 | (assoc :pc start-expr-label 746 | :statements [] 747 | :terminate? (restrict (:terminate? ctx) (pc= end-label))) 748 | (process-insns))] 749 | [(if hash-identity? :hash-identity :hash-equiv) match test (expr+statements expr-ctx) (:recur? expr-ctx)])) 750 | 751 | 752 | (if (or (= "invokevirtual" (:insn/name (insn-at ctx {:offset -1}))) 753 | (and (= "invokevirtual" (:insn/name (maybe-insn-at ctx {:offset -5}))) 754 | (= "iand" (:insn/name (insn-at ctx {:offset -1}))))) 755 | 756 | (let [{:keys [stack] :as test-ctx} (-> ctx 757 | (assoc :pc label 758 | :statements [] 759 | :terminate? (restrict (:terminate? ctx) 760 | (fn [ctx] 761 | (= "invokestatic" (:insn/name (curr-insn ctx)))))) 762 | (process-insns)) 763 | test (peek stack) 764 | 765 | expr-ctx (-> ctx 766 | (assoc :pc (:insn/label (insn-at test-ctx {:offset 2})) 767 | :statements [] 768 | :terminate? (restrict (:terminate? ctx) (pc= end-label))) 769 | (process-insns))] 770 | [:int match test (expr+statements expr-ctx) (:recur? expr-ctx)]) 771 | 772 | (let [{:keys [stack] :as test-ctx} (-> ctx 773 | (assoc :pc label 774 | :statements [] 775 | :terminate? (-> (:terminate? ctx) 776 | (restrict (pc= end-label)) 777 | (restrict (fn [ctx] 778 | (and (= "lcmp" (:insn/name (curr-insn ctx))) 779 | (= default-label (goto-label (insn-at ctx {:offset 1})))))))) 780 | (process-insns))] 781 | 782 | (if (= "lcmp" (:insn/name (curr-insn test-ctx))) 783 | (let [[test _] (peek-n stack 2) 784 | expr-ctx (-> ctx 785 | (assoc :pc (:insn/label (insn-at test-ctx {:offset 2})) 786 | :statements [] 787 | :terminate? (restrict (:terminate? ctx) (pc= end-label))) 788 | (process-insns))] 789 | [:int match test (expr+statements expr-ctx) (:recur? expr-ctx)]) 790 | 791 | [:int match {:op :const :val match} (peek stack) (:recur? test-ctx)]))))) 792 | 793 | (into [])) 794 | 795 | end-label (-> (insn-at ctx {:label default-label :offset -1}) (goto-label)) 796 | 797 | default-expr (-> ctx 798 | (assoc :pc default-label 799 | :statements [] 800 | :terminate? (restrict (:terminate? ctx) (pc= end-label))) 801 | (process-insns) 802 | (expr+statements)) 803 | expr {:op :case 804 | :test test 805 | :shift (or ?shift 0) 806 | :mask (or ?mask 0) 807 | :default default-expr 808 | :type (if (= "lookuptable" (:insn/name insn)) :sparse :compact) 809 | :switch-type (if hash-test? (if (every? (comp #{:hash-identity} first) exprs) :hash-identity :hash-equiv) :int) 810 | :skip-check (when hash-test? 811 | (->> (for [i (range (count exprs)) 812 | :let [[type] (nth exprs i)] 813 | :when (= :collision type)] 814 | i) 815 | (into #{}))) 816 | :exprs exprs} 817 | recur? (boolean (seq (for [[_ _ _ _ recur?] exprs 818 | :when recur?] 819 | true)))] 820 | 821 | (-> ctx 822 | (assoc :recur? recur?) 823 | (update :stack pop) 824 | (update :stack conj expr) 825 | (assoc :pc end-label)))) 826 | 827 | (defmethod process-insn :instanceof [{:keys [stack] :as ctx} {:insn/keys [pool-element]}] 828 | 829 | (if (or (isa? bc/insn-h (-> (maybe-insn-at ctx {:offset 5}) :insn/name keyword) ::bc/select) 830 | (and (isa? bc/insn-h (-> (maybe-insn-at ctx {:offset 9}) :insn/name keyword) ::bc/select) 831 | (= "ishr" (-> (insn-at ctx {:offset 6}) :insn/name)))) 832 | 833 | (-> ctx 834 | (assoc :pc (:insn/label (insn-at ctx {:offset 5})))) 835 | 836 | 837 | (let [{:insn/keys [target-type]} pool-element 838 | instance (peek stack)] 839 | (-> ctx 840 | (update :stack pop) 841 | (update :stack conj {:op :invoke 842 | :fn {:op :var 843 | :ns "clojure.core" 844 | :name "instance?"} 845 | :args [{:op :const 846 | :val (symbol target-type)} 847 | instance]}))))) 848 | 849 | ;; WIP new on :new rather than invokespecial 850 | (defmethod process-insn :new [ctx _] 851 | ctx) 852 | 853 | (defmethod process-insn :invokespecial [{:keys [stack bc-for lenient?] :as ctx} {:insn/keys [pool-element]}] 854 | (let [{:insn/keys [target-class target-arg-types]} pool-element 855 | argc (count target-arg-types) 856 | args (peek-n stack argc)] 857 | (-> ctx 858 | (update :stack pop-n (inc argc)) 859 | (update :stack conj (let [bc (bc-for target-class)] 860 | (if (or (#{"clojure.lang.AFunction" "clojure.lang.RestFn" } (:class/super bc)) 861 | (and (some #{"clojure.lang.IObj"} (:class/interfaces bc)) 862 | (.contains ^String target-class "$reify__"))) 863 | (bc->ast bc {:bc-for bc-for :lenient? lenient?}) 864 | {:op :new 865 | :class target-class 866 | :args args})))))) 867 | 868 | (defmethod process-insn :athrow [{:keys [stack reachable pc] :as ctx} _] 869 | (if-not (contains? reachable pc) 870 | ctx 871 | (let [ex (peek stack)] 872 | (-> ctx 873 | (update :stack pop) 874 | (update :statements conj {:op :throw 875 | :ex ex}))))) 876 | 877 | (defmethod process-insn ::bc/invoke-instance-method [{:keys [stack bc-for ^String class-name lenient?] :as ctx} {:insn/keys [pool-element]}] 878 | (let [{:insn/keys [target-class target-name target-ret-type target-arg-types]} pool-element 879 | argc (count (conj target-arg-types target-class)) 880 | [target & args] (peek-n stack argc) 881 | ?deftype-ast (when (and (= "importClass" target-name) 882 | (= "clojure.lang.Namespace" target-class)) 883 | (let [^String cname (-> args first :args first :val)] 884 | (when-let [bc (and (= (subs cname 0 (.lastIndexOf cname ".")) 885 | (let [i (.indexOf class-name "$")] 886 | (-> class-name 887 | (s/replace "__init" "") 888 | (cond-> (not= i -1) 889 | (subs 0 i))))) 890 | (bc-for cname))] 891 | (when (some #{"clojure.lang.IType" "clojure.lang.IRecord"} (:class/interfaces bc)) 892 | (bc->ast bc {:bc-for bc-for :lenient? lenient?})))))] 893 | (-> ctx 894 | (update :stack pop-n argc) 895 | (update (if (= "void" target-ret-type) :statements :stack) 896 | conj {:op :invoke-instance 897 | :method target-name 898 | :target target 899 | :arg-types target-arg-types 900 | :target-class target-class 901 | :args args}) 902 | (cond-> ?deftype-ast 903 | (update :statements conj ?deftype-ast))))) 904 | 905 | (defmethod process-insn :putstatic [{:keys [stack class-name] :as ctx} {:insn/keys [pool-element]}] 906 | (let [{:insn/keys [target-class target-name]} pool-element 907 | val (peek stack) 908 | ctx (update ctx :stack pop)] 909 | (if (= class-name target-class) 910 | (-> ctx 911 | (update :fields assoc target-name val)) 912 | (-> ctx 913 | (update :statements conj {:op :set! 914 | :target {:op :static-field 915 | :target target-class 916 | :field target-name} 917 | :val val}))))) 918 | 919 | (defn process-keyword-invoke [{:keys [fields] :as ctx} {:insn/keys [pool-element]}] 920 | (let [{:insn/keys [target-name]} pool-element 921 | {:keys [pc statements stack]} (process-insns (assoc ctx 922 | :pc (:insn/label (insn-at ctx {:offset 2})) 923 | :terminate? (restrict (:terminate? ctx) 924 | (fn [ctx] 925 | (->> (curr-insn ctx) 926 | :insn/name 927 | (= "dup_x2")))) 928 | :statements [])) 929 | target (->do (conj statements (peek stack)))] 930 | (-> ctx 931 | (assoc :pc (+ pc 36)) ;; why bother writing robust code when we can just hardcode bytecode offsets 932 | (update :stack conj {:op :invoke 933 | :fn (-> (get-in fields [target-name :args 0 :args 1]) 934 | (update :val keyword)) 935 | :args [target]})))) 936 | 937 | (defmethod process-insn :getstatic [{:keys [fields class-name] :as ctx} {:insn/keys [pool-element] :as insn}] 938 | (let [{:insn/keys [target-class target-name target-type]} pool-element] 939 | (cond 940 | 941 | (and (= target-type "clojure.lang.ILookupThunk") 942 | (= target-class class-name)) 943 | (process-keyword-invoke ctx insn) 944 | 945 | (= target-class class-name) 946 | (update ctx :stack conj (get fields target-name)) 947 | 948 | :else 949 | (update ctx :stack conj {:op :static-field 950 | :target target-class 951 | :field target-name})))) 952 | 953 | (defmethod process-insn :putfield [{:keys [class-name stack] :as ctx} {:insn/keys [pool-element]}] 954 | (let [{:insn/keys [target-class target-name]} pool-element 955 | [instance val] (peek-n stack 2)] 956 | (-> ctx 957 | (update :stack pop-n 2) 958 | (cond-> (not= :closed-over (:op val)) 959 | (update :statements conj {:op :set! 960 | :target (if (= target-class class-name) 961 | {:op :local 962 | :name target-name} 963 | {:op :instance-field 964 | :instance instance 965 | :field target-name}) 966 | :val val}))))) 967 | 968 | (defn skip-locals-clearing-field [ctx] 969 | ;; WIP must make sure it's not a mutable deftype field 970 | (if (and (= "aload_0" (:insn/name (insn-at ctx {:offset 1}))) 971 | (= "aconst_null" (:insn/name (insn-at ctx {:offset 2}))) 972 | (= "putfield" (:insn/name (insn-at ctx {:offset 3}))) 973 | (= (-> (curr-insn ctx) :insn/pool-element :insn/target-name) 974 | (-> (insn-at ctx {:offset 3}) :insn/pool-element :insn/target-name))) 975 | (-> ctx 976 | (assoc :pc (:insn/label (insn-at ctx {:offset 4})))) 977 | ctx)) 978 | 979 | (defmethod process-insn :getfield [{:keys [fields class-name stack] :as ctx} {:insn/keys [pool-element]}] 980 | (let [{:insn/keys [target-class target-name]} pool-element 981 | instance (peek stack) 982 | ctx (update ctx :stack pop)] 983 | (if (= target-class class-name) 984 | (-> ctx 985 | (update :stack conj (get fields target-name {:op :local :name (bc/fixup-name target-name)})) 986 | (skip-locals-clearing-field)) 987 | (update ctx :stack conj {:op :instance-field 988 | :instance instance 989 | :field target-name})))) 990 | 991 | (defmethod process-insn :invokestatic [{:keys [stack] :as ctx} {:insn/keys [pool-element]}] 992 | (let [{:insn/keys [target-class target-name target-ret-type target-arg-types]} pool-element 993 | argc (count target-arg-types) 994 | args (peek-n stack argc)] 995 | (-> ctx 996 | (update :stack pop-n argc) 997 | (update (if (= "void" target-ret-type) :statements :stack) 998 | conj {:op :invoke-static 999 | :target target-class 1000 | :method target-name 1001 | :arg-types target-arg-types 1002 | :args args})))) 1003 | 1004 | (defmethod process-insn ::bc/math-insn [{:keys [stack] :as ctx} {:insn/keys [name]}] 1005 | (let [argc (if (#{"dneg" "lneg"} name) 1 2) 1006 | args (peek-n stack argc) 1007 | op ({"dadd" "+" 1008 | "ddiv" "/" 1009 | "dmul" "*" 1010 | "dneg" "-" 1011 | "dsub" "-" 1012 | "iadd" "+" 1013 | "iand" "bit-and" 1014 | "idiv" "/" 1015 | "imul" "*" 1016 | "irem" "rem" 1017 | "ineg" "-" 1018 | "ishl" "bit-shift-left" 1019 | "ishr" "bit-shift-right" 1020 | "isub" "-" 1021 | "iushr" "unsigned-bit-shift-right" 1022 | "ladd" "+" 1023 | "land" "bit-and" 1024 | "ldiv" "quot" 1025 | "lneg" "-" 1026 | "lmul" "*" 1027 | "lor" "bit-or" 1028 | "lrem" "rem" 1029 | "lshl" "bit-shift-left" 1030 | "lshr" "bit-shift-right" 1031 | "lsub" "-" 1032 | "lushr" "unsigned-bit-shift-right" 1033 | "lxor" "bit-xor"} name)] 1034 | (-> ctx 1035 | (update :stack pop-n argc) 1036 | (update :stack conj {:op :invoke 1037 | :fn {:op :var 1038 | :ns "clojure.core" 1039 | :name op} 1040 | :args args})))) 1041 | 1042 | (defmethod process-insn :checkcast [{:keys [stack] :as ctx} {:insn/keys [pool-element]}] 1043 | (let [{:insn/keys [target-type]} pool-element 1044 | target (peek stack)] 1045 | 1046 | (cond-> ctx 1047 | 1048 | target 1049 | (-> (update :stack pop) 1050 | (update :stack conj (assoc target :cast target-type)))))) 1051 | 1052 | ;; protocol inline caches 1053 | (defmethod process-insn :if_acmpeq [{:keys [stack] :as ctx} _] 1054 | (-> ctx 1055 | (update :stack pop-n 2) 1056 | (update :pc + 17))) 1057 | 1058 | (defn merge-tables [ctx local-variable-table exception-table] 1059 | (let [lvt (->> (for [{:local-variable/keys [name index start-label end-label]} local-variable-table] 1060 | {:op :local 1061 | :start-label start-label 1062 | :end-label end-label 1063 | :index index 1064 | :name name}) 1065 | (into #{})) 1066 | et (->> (for [{:exception-handler/keys [type start-label end-label handler-label]} exception-table] 1067 | {:start-label start-label 1068 | :end-label end-label 1069 | :handler-label handler-label 1070 | :type type}) 1071 | (into #{}))] 1072 | (-> ctx 1073 | (assoc :local-variable-table lvt) 1074 | (assoc :exception-table et) 1075 | (assoc :loop-args (->> lvt 1076 | (filter (comp zero? :start-label)) 1077 | (sort-by :index) 1078 | (vec)))))) 1079 | 1080 | (defn collect-impure-loops-data [{:keys [insns] :as ctx}] 1081 | (loop [[insn & insns] insns data #{}] 1082 | (if insn 1083 | (if (and (= "goto" (:insn/name insn)) 1084 | (not (pos? (:insn/jump-offset insn))) 1085 | (not (isa? bc/insn-h (-> ctx 1086 | (assoc :pc (:insn/label insn)) 1087 | (maybe-insn-at {:offset -1}) 1088 | :insn/name 1089 | keyword) 1090 | ::bc/store-insn))) 1091 | (recur insns (conj data (goto-label insn))) 1092 | (recur insns data)) 1093 | (assoc ctx :impure-loops data)))) 1094 | 1095 | (defn process-method-insns [{:keys [fn-name] :as ctx} {:method/keys [bytecode jump-table local-variable-table flags exception-table]}] 1096 | (println fn-name) 1097 | (-> ctx 1098 | (merge initial-local-ctx {:jump-table jump-table}) 1099 | (merge-tables local-variable-table exception-table) 1100 | (cond-> (not (:static flags)) 1101 | (-> (update :local-variable-table disj {:op :local 1102 | :start-label 0 1103 | :end-label (-> bytecode peek :insn/label) 1104 | :index 0 1105 | :name "this"}) 1106 | (update :local-variable-table conj {:op :local 1107 | :this? true 1108 | :index 0 1109 | :name (or fn-name "this") 1110 | :start-label 0 1111 | :end-label (-> bytecode peek :insn/label)}) 1112 | (update :loop-args #(vec (rest %))))) 1113 | (assoc :insns bytecode) 1114 | (collect-impure-loops-data) 1115 | (collect-reachable) 1116 | (process-insns))) 1117 | 1118 | (defn process-static-init [{:keys [bc-for] :as ctx} {:class/keys [methods]}] 1119 | (let [method (u/find-method methods {:method/name ""})] 1120 | (-> ctx 1121 | (process-method-insns method)))) 1122 | 1123 | (defn process-init [{:keys [bc-for] :as ctx} {:class/keys [methods]}] 1124 | (let [method (u/find-method methods {:method/name ""}) 1125 | {:method/keys [arg-types]} method] 1126 | (-> ctx 1127 | (assoc :closed-overs (second (reduce (fn [[i c] a] [(+ i a) (conj c i)]) [1 #{0}] 1128 | (map #({"long" 2 "double" 2} % 1) 1129 | arg-types)))) 1130 | (process-method-insns method)))) 1131 | 1132 | (defn decompile-fn-method [{:keys [fn-name] :as ctx} {:method/keys [local-variable-table flags name] :as method}] 1133 | (let [{:keys [ast]} (process-method-insns ctx method) 1134 | args (for [{:local-variable/keys [index name type start-label]} (->> local-variable-table 1135 | (sort-by :local-variable/index)) 1136 | :when (and (zero? start-label) 1137 | (or (:static flags) 1138 | (not (zero? index))))] 1139 | {:name name 1140 | :type type})] 1141 | 1142 | {:op :fn-method 1143 | :fn-name fn-name 1144 | :var-args? (or (= "doInvoke" name) 1145 | (= "clojure.lang.ISeq" (-> args last :type))) 1146 | :args args 1147 | :body ast})) 1148 | 1149 | (defn decompile-fn-methods [{:keys [fn-name] :as ctx} {:class/keys [methods]}] 1150 | (let [invokes-static (u/find-methods methods {:method/name "invokeStatic"}) 1151 | invokes-prim (u/find-methods methods {:method/name "invokePrim"}) 1152 | invokes (u/find-methods methods {:method/name "invoke"}) 1153 | invoke-vararg (u/find-method methods {:method/name "doInvoke"}) 1154 | invoke-methods (-> invokes-static 1155 | (into (for [{:method/keys [arg-types] :as invoke} invokes-prim 1156 | :let [argc (count arg-types)] 1157 | :when (empty? (filter (fn [{:method/keys [arg-types]}] 1158 | (= (count arg-types) argc)) 1159 | invokes-static))] 1160 | invoke))) 1161 | 1162 | invoke-methods (-> invoke-methods 1163 | (into (for [{:method/keys [arg-types] :as invoke} (into invokes (when invoke-vararg 1164 | [invoke-vararg])) 1165 | :let [argc (count arg-types)] 1166 | :when (empty? (filter (fn [{:method/keys [arg-types]}] 1167 | (= (count arg-types) argc)) 1168 | invoke-methods))] 1169 | invoke))) 1170 | methods-asts (mapv (partial decompile-fn-method ctx) invoke-methods)] 1171 | {:op :fn 1172 | :name fn-name 1173 | :fn-methods methods-asts})) 1174 | 1175 | (defn extract-fn-name [^String cname] 1176 | (let [fname (subs cname (inc (.lastIndexOf cname "$"))) 1177 | pretty-fname (second (re-matches #"(.+)__[0-9]+$" fname))] 1178 | (if (and pretty-fname 1179 | (not= pretty-fname "fn")) 1180 | pretty-fname 1181 | fname))) 1182 | 1183 | (defn decompile-fn [{class-name :class/name :as bc} {:keys [fn-name] :as ctx}] 1184 | (-> ctx 1185 | (assoc :fn-name (or fn-name (extract-fn-name class-name))) 1186 | (assoc :class-name class-name) 1187 | (process-static-init bc) 1188 | (process-init bc) 1189 | (decompile-fn-methods bc))) 1190 | 1191 | 1192 | (defn process-ns-inits [ctx {:class/keys [methods]}] 1193 | (reduce (fn [ctx i] 1194 | (if-let [method (u/find-method methods {:method/name (str "__init" i)})] 1195 | (process-method-insns ctx method) 1196 | (reduced ctx))) 1197 | ctx (range))) 1198 | 1199 | (defn process-ns-load [ctx {:class/keys [methods]}] 1200 | (let [{:method/keys [bytecode jump-table]} (u/find-method methods {:method/name "load"}) 1201 | ctx (-> ctx 1202 | (assoc 1203 | :terminate? (restrict (:terminate? ctx) (comp seq :statements)) 1204 | :insns bytecode) 1205 | (merge initial-local-ctx {:jump-table jump-table})) 1206 | indicize (fn [s i] 1207 | (reduce (fn [[s i] insn] 1208 | (if (::idx insn) 1209 | [(conj s insn) i] 1210 | [(conj s (assoc insn ::idx i)) (inc i)])) 1211 | [[] i] s))] 1212 | (loop [{:keys [stack statements] :as ctx} (process-insns ctx) 1213 | init [] 1214 | i 0] 1215 | (let [[stack i] (indicize stack i) 1216 | [statements i] (indicize statements i)] 1217 | (if (and (seq statements)) 1218 | (recur (process-insns (assoc ctx :statements [] :stack stack)) 1219 | (into init statements) 1220 | i) 1221 | (->do (sort-by ::idx (concat init stack statements)))))))) 1222 | 1223 | (defn decompile-ns [{class-name :class/name :as bc} {:keys [fn-name] :as ctx}] 1224 | (-> ctx 1225 | (assoc :class-name class-name) 1226 | (process-ns-inits bc) 1227 | (process-ns-load bc))) 1228 | 1229 | (defn process-methods [ctx methods] 1230 | (->> (for [{:method/keys [name local-variable-table] :as method} methods] 1231 | {:op :method 1232 | :name name 1233 | :args (->> (for [{:local-variable/keys [name start-label type]} (->> local-variable-table 1234 | (sort-by :local-variable/index)) 1235 | :when (zero? start-label)] 1236 | {:name name 1237 | :type type}) 1238 | (into [])) 1239 | :body (:ast (process-method-insns ctx method))}) 1240 | (into []))) 1241 | 1242 | ;; deftypes with `this` as a field break 1243 | (defn decompile-deftype [{:class/keys [fields interfaces methods ^String name] :as bc} ctx] 1244 | (let [fields (->> (for [{:field/keys [name flags]} fields 1245 | :when (not (:static flags))] 1246 | {:name name 1247 | :mutable? (cond 1248 | (:volatile flags) :volatile-mutable 1249 | (:final flags) false 1250 | :else :unsynchronized-mutable)}) 1251 | (into [])) 1252 | instance-methods (->> methods 1253 | (remove (comp :static :method/flags)) 1254 | ;; bridge 1255 | (remove (comp :volatile :method/flags)) 1256 | (remove (comp #{""} :method/name))) 1257 | ctx (-> ctx (assoc :class-name name) (process-static-init bc))] 1258 | {:op :deftype 1259 | :name name 1260 | :tname (.replaceFirst name "\\." "/") 1261 | :fields fields 1262 | :methods (process-methods ctx instance-methods) 1263 | :interfaces interfaces})) 1264 | 1265 | (defn decompile-reify [{:class/keys [interfaces methods name] :as bc} ctx] 1266 | (let [instance-methods (->> methods 1267 | (remove (comp :static :method/flags)) 1268 | ;; bridge 1269 | (remove (comp :volatile :method/flags)) 1270 | (remove (comp #{"" "meta" "withMeta"} :method/name))) 1271 | ctx (-> ctx 1272 | (assoc :class-name name) 1273 | (process-static-init bc))] 1274 | {:op :reify 1275 | :methods (process-methods ctx instance-methods) 1276 | :interfaces (vec (remove #{"clojure.lang.IObj"} interfaces))})) 1277 | 1278 | (defn bc->ast [{:class/keys [interfaces super ^String name] :as bc} ctx] 1279 | (let [ctx (merge ctx initial-ctx)] 1280 | (try 1281 | (cond 1282 | (#{"clojure.lang.AFunction" "clojure.lang.RestFn"} super) 1283 | (decompile-fn bc ctx) 1284 | 1285 | (.endsWith name "__init") 1286 | (decompile-ns bc ctx) 1287 | 1288 | (some #{"clojure.lang.IType" "clojure.lang.IRecord"} interfaces) 1289 | (decompile-deftype bc ctx) 1290 | 1291 | (and (some #{"clojure.lang.IObj"} interfaces) 1292 | (.contains name "$reify__")) 1293 | (decompile-reify bc ctx) 1294 | 1295 | :else 1296 | (throw (Exception. ":("))) 1297 | (catch Exception e 1298 | (if (:lenient? ctx) 1299 | {:op :const :val (str "BROKEN DECOMP " name)} 1300 | (throw e)))))) 1301 | 1302 | ;;; genclass 1303 | ;; WIP int -> booleans 1304 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/bc.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.bc 10 | (:require [clojure.string :as s]) 11 | (:import (org.apache.bcel.classfile ClassParser JavaClass Field AccessFlags Method 12 | ConstantPool ConstantObject ConstantCP ConstantNameAndType 13 | Utility LocalVariable) 14 | (org.apache.bcel.generic Instruction InstructionList BranchInstruction CPInstruction ConstantPushInstruction MethodGen 15 | ConstantPoolGen LocalVariableInstruction TypedInstruction IndexedInstruction CodeExceptionGen NEWARRAY Select) 16 | java.io.ByteArrayInputStream 17 | clojure.tools.decompiler.RetrieveClasses)) 18 | 19 | ;; Implementaiton is limited to the set of bytecode produced by Clojure compiler as of version 1.9.0 20 | 21 | (set! *warn-on-reflection* true) 22 | 23 | (defn parse-class ^JavaClass [^String classfile-or-classname] 24 | (let [cp (if (.endsWith classfile-or-classname ".class") 25 | (ClassParser. classfile-or-classname) 26 | (ClassParser. (ByteArrayInputStream. (get (RetrieveClasses/getClasses) classfile-or-classname)) ""))] 27 | (.parse cp))) 28 | 29 | (defn parse-flags [^AccessFlags flags] 30 | (cond-> #{} 31 | (.isAbstract flags) (conj :abstract) 32 | (.isFinal flags) (conj :final) 33 | (.isInterface flags) (conj :interface) 34 | (.isPrivate flags) (conj :private) 35 | (.isProtected flags) (conj :protected) 36 | (.isPublic flags) (conj :public) 37 | (.isStatic flags) (conj :static) 38 | (.isSynchronized flags) (conj :synchronized) 39 | (.isSynthetic flags) (conj :synthetic) 40 | (.isVolatile flags) (conj :volatile))) 41 | 42 | (defn parse-field [^Field field] 43 | (let [type (-> field 44 | (.getType) 45 | (str)) 46 | name (.getName field)] 47 | {:field/name name 48 | :field/type type 49 | :field/flags (parse-flags field)})) 50 | 51 | (defn class-fields [^JavaClass klass] 52 | (->> klass 53 | (.getFields) 54 | (mapv parse-field))) 55 | 56 | (defmulti -parse-insn (fn [^JavaClass klass ^Instruction insn] (class insn))) 57 | 58 | (defmethod -parse-insn :default [_ _]) 59 | 60 | (defn type-from-pool-gen [^JavaClass klass ^TypedInstruction insn] 61 | (->> klass 62 | (.getConstantPool) 63 | (ConstantPoolGen.) 64 | (.getType insn) 65 | (str))) 66 | 67 | (defmethod -parse-insn LocalVariableInstruction 68 | [^JavaClass klass ^LocalVariableInstruction insn] 69 | {:insn/local-variable-element {:insn/target-type (type-from-pool-gen klass insn) 70 | :insn/target-index (.getIndex insn)}}) 71 | 72 | (defmethod -parse-insn NEWARRAY 73 | [^JavaClass klass ^NEWARRAY insn] 74 | {:insn/target-type (str (.getType insn))}) 75 | 76 | (defmethod -parse-insn BranchInstruction 77 | [_ ^BranchInstruction insn] 78 | (if (instance? Select insn) 79 | (let [^Select insn insn] 80 | {:insn/jump-targets {:insn/jump-offsets (vec (.getIndices insn)) 81 | :insn/default-offset (.getIndex insn) 82 | :insn/jump-matches (vec (.getMatchs insn))}}) 83 | {:insn/jump-offset (.getIndex insn)})) 84 | 85 | (defmethod -parse-insn ConstantPushInstruction 86 | [^JavaClass klass ^ConstantPushInstruction insn] 87 | {:insn/pool-element {:insn/target-value (.getValue insn) 88 | :insn/target-type (type-from-pool-gen klass insn)}}) 89 | 90 | (defn parse-pool-element [^JavaClass klass ^IndexedInstruction insn] 91 | (let [idx (.getIndex insn) 92 | pool (.getConstantPool klass) 93 | constant (.getConstant pool idx)] 94 | (if (instance? ConstantObject constant) 95 | {:insn/target-value (.getConstantValue ^ConstantObject constant pool) 96 | :insn/target-type (type-from-pool-gen klass insn)} 97 | ;; methods + field refs 98 | (let [^ConstantCP constant constant 99 | ^ConstantNameAndType name-and-type (.getConstant pool (.getNameAndTypeIndex constant)) 100 | signature (.getSignature name-and-type pool)] 101 | (merge 102 | {:insn/target-class (.getClass constant pool) 103 | :insn/target-name (.getName name-and-type pool)} 104 | (if (.startsWith signature "(") 105 | {:insn/target-arg-types (vec (Utility/methodSignatureArgumentTypes signature false)) 106 | :insn/target-ret-type (Utility/methodSignatureReturnType signature false)} 107 | {:insn/target-type (Utility/signatureToString signature false)})))))) 108 | 109 | (defmethod -parse-insn CPInstruction 110 | [^JavaClass klass ^CPInstruction insn] 111 | {:insn/pool-element (parse-pool-element klass insn)}) 112 | 113 | (defn parse-insn [^JavaClass klass ^Instruction insn] 114 | (merge 115 | {:insn/name (.getName insn) 116 | :insn/length (.getLength insn)} 117 | (-parse-insn klass insn))) 118 | 119 | (defn add-labels [insns insn] 120 | (let [label (if-let [{:insn/keys [label length]} (peek insns)] 121 | (+ label length) 122 | 0)] 123 | (conj insns (assoc insn :insn/label label)))) 124 | 125 | (defn parse-bytecode [^JavaClass klass ^Method method] 126 | (->> method 127 | (.getCode) 128 | (.getCode) 129 | (InstructionList.) 130 | (.getInstructions) 131 | (mapv (partial parse-insn klass)) 132 | (reduce add-labels []))) 133 | 134 | (defn fixup-name [name] 135 | (let [name (or (second (re-matches #"(.*)__auto__[0-9]+$" name)) name)] 136 | (reduce (fn [n [p m]] (s/replace n p (str m))) 137 | name 138 | (dissoc clojure.lang.Compiler/DEMUNGE_MAP "_")))) 139 | 140 | (defn fixup-lvt [lvt] 141 | (let [els (group-by (comp zero? :local-variable/start-label) lvt) 142 | args (get els true) 143 | locals (get els false)] 144 | (concat locals 145 | (second 146 | (reduce 147 | (fn [[i lvt] {:local-variable/keys [index type] :as lv}] 148 | [(+ i ({"long" 2 "double" 2} type 1)) (conj lvt (assoc lv :local-variable/index i))]) 149 | [0 #{}] 150 | (sort-by :index args)))))) 151 | 152 | (defn parse-local-variable-table [local-variable-table] 153 | (fixup-lvt 154 | (for [^LocalVariable local-variable local-variable-table] 155 | #:local-variable{:name (fixup-name (.getName local-variable)) 156 | :start-label (.getStartPC local-variable) 157 | :end-label (+ (.getStartPC local-variable) 158 | (.getLength local-variable)) 159 | :index (.getIndex local-variable) 160 | :type (Utility/signatureToString (.getSignature local-variable) false)}))) 161 | 162 | (defn parse-exception-table [^JavaClass klass ^Method method] 163 | (let [cp-gen (ConstantPoolGen. (.getConstantPool klass)) 164 | ex-handlers (.getExceptionHandlers (MethodGen. method (.getClassName klass) cp-gen))] 165 | (for [^CodeExceptionGen ex ex-handlers] 166 | #:exception-handler{:type (some-> ex (.getCatchType) (.getClassName)) 167 | :start-label (.getPosition (.getStartPC ex)) 168 | :end-label (.getPosition (.getEndPC ex)) 169 | :handler-label (.getPosition (.getHandlerPC ex))}))) 170 | 171 | (defn parse-method [^JavaClass klass ^Method method] 172 | (let [bytecode (parse-bytecode klass method)] 173 | #:method{:name (.getName method) 174 | :flags (parse-flags method) 175 | :return-type (-> method (.getReturnType) (str)) 176 | :arg-types (->> method (.getArgumentTypes) (mapv str)) 177 | :bytecode bytecode 178 | :jump-table (into {} (for [i (range (count bytecode)) 179 | :let [{:keys [insn/label]} (nth bytecode i)]] 180 | [label i])) 181 | :exception-table (into #{} (parse-exception-table klass method)) 182 | :local-variable-table (->> 183 | (some-> method 184 | (.getLocalVariableTable) 185 | (.getLocalVariableTable) 186 | (parse-local-variable-table)) 187 | (into #{}))})) 188 | 189 | (defn class-methods [^JavaClass klass] 190 | (->> klass 191 | (.getMethods) 192 | (remove #(.isAbstract ^Method %)) 193 | (mapv (partial parse-method klass)))) 194 | 195 | (defn analyze-class [classfile-or-classname] 196 | (let [klass (parse-class classfile-or-classname)] 197 | {:class/name (.getClassName klass) 198 | :class/filename (.getSourceFileName klass) 199 | 200 | :class/type (if (.isClass klass) 201 | :class 202 | :interface) 203 | 204 | :class/flags (parse-flags klass) 205 | 206 | :class/super (-> klass (.getSuperclassName)) 207 | :class/interfaces (vec (.getInterfaceNames klass)) 208 | 209 | :class/fields (class-fields klass) 210 | :class/methods (class-methods klass)})) 211 | 212 | (def insn-h 213 | (-> (make-hierarchy) 214 | (derive :ldc ::const-insn) 215 | (derive :ldc_w ::const-insn) 216 | (derive :ldc2_w ::const-insn) 217 | (derive :aconst_null ::const-insn) 218 | (derive :bipush ::const-insn) 219 | (derive :sipush ::const-insn) 220 | (derive :dconst_0 ::const-insn) 221 | (derive :dconst_1 ::const-insn) 222 | (derive :iconst_0 ::const-insn) 223 | (derive :fconst_1 ::const-insn) 224 | (derive :fconst_2 ::const-insn) 225 | (derive :fconst_3 ::const-insn) 226 | (derive :iconst_m1 ::const-insn) 227 | (derive :iconst_0 ::const-insn) 228 | (derive :iconst_1 ::const-insn) 229 | (derive :iconst_2 ::const-insn) 230 | (derive :iconst_3 ::const-insn) 231 | (derive :iconst_4 ::const-insn) 232 | (derive :iconst_5 ::const-insn) 233 | (derive :lconst_0 ::const-insn) 234 | (derive :lconst_1 ::const-insn) 235 | (derive :lconst_2 ::const-insn) 236 | 237 | (derive :invokeinterface ::invoke-instance-method) 238 | (derive :invokevirtual ::invoke-instance-method) 239 | 240 | (derive :astore ::store-insn) 241 | (derive :astore_0 ::store-insn) 242 | (derive :astore_1 ::store-insn) 243 | (derive :astore_2 ::store-insn) 244 | (derive :astore_3 ::store-insn) 245 | (derive :dstore ::store-insn) 246 | (derive :dstore_0 ::store-insn) 247 | (derive :dstore_1 ::store-insn) 248 | (derive :dstore_2 ::store-insn) 249 | (derive :dstore_3 ::store-insn) 250 | (derive :fstore ::store-insn) 251 | (derive :fstore_0 ::store-insn) 252 | (derive :fstore_1 ::store-insn) 253 | (derive :fstore_2 ::store-insn) 254 | (derive :fstore_3 ::store-insn) 255 | (derive :istore ::store-insn) 256 | (derive :istore_0 ::store-insn) 257 | (derive :istore_1 ::store-insn) 258 | (derive :istore_2 ::store-insn) 259 | (derive :istore_3 ::store-insn) 260 | (derive :lstore ::store-insn) 261 | (derive :lstore_0 ::store-insn) 262 | (derive :lstore_1 ::store-insn) 263 | (derive :lstore_2 ::store-insn) 264 | (derive :lstore_3 ::store-insn) 265 | 266 | (derive :aload ::load-insn) 267 | (derive :aload_0 ::load-insn) 268 | (derive :aload_1 ::load-insn) 269 | (derive :aload_2 ::load-insn) 270 | (derive :aload_3 ::load-insn) 271 | (derive :dload ::load-insn) 272 | (derive :dload_0 ::load-insn) 273 | (derive :dload_1 ::load-insn) 274 | (derive :dload_2 ::load-insn) 275 | (derive :dload_3 ::load-insn) 276 | (derive :fload ::load-insn) 277 | (derive :fload_0 ::load-insn) 278 | (derive :fload_1 ::load-insn) 279 | (derive :fload_2 ::load-insn) 280 | (derive :fload_3 ::load-insn) 281 | (derive :iload ::load-insn) 282 | (derive :iload_0 ::load-insn) 283 | (derive :iload_1 ::load-insn) 284 | (derive :iload_2 ::load-insn) 285 | (derive :iload_3 ::load-insn) 286 | (derive :lload ::load-insn) 287 | (derive :lload_0 ::load-insn) 288 | (derive :lload_1 ::load-insn) 289 | (derive :lload_2 ::load-insn) 290 | (derive :lload_3 ::load-insn) 291 | 292 | (derive :aastore ::array-store) 293 | (derive :bastore ::array-store) 294 | (derive :castore ::array-store) 295 | (derive :dastore ::array-store) 296 | (derive :fastore ::array-store) 297 | (derive :iastore ::array-store) 298 | (derive :lastore ::array-store) 299 | (derive :sastore ::array-store) 300 | 301 | (derive :areturn ::return-value) 302 | (derive :dreturn ::return-value) 303 | (derive :freturn ::return-value) 304 | (derive :ireturn ::return-value) 305 | (derive :lreturn ::return-value) 306 | (derive :sreturn ::return-value) 307 | 308 | (derive :dneg ::math-insn) 309 | (derive :lneg ::math-insn) 310 | 311 | (derive :dadd ::math-insn) 312 | (derive :ddiv ::math-insn) 313 | (derive :dmul ::math-insn) 314 | (derive :dsub ::math-insn) 315 | (derive :iadd ::math-insn) 316 | (derive :iand ::math-insn) 317 | (derive :idiv ::math-insn) 318 | (derive :imul ::math-insn) 319 | (derive :irem ::math-insn) 320 | (derive :ishl ::math-insn) 321 | (derive :ishr ::math-insn) 322 | (derive :isub ::math-insn) 323 | (derive :iushr ::math-insn) 324 | (derive :ladd ::math-insn) 325 | (derive :land ::math-insn) 326 | (derive :ldiv ::math-insn) 327 | (derive :lmul ::math-insn) 328 | (derive :lor ::math-insn) 329 | (derive :lrem ::math-insn) 330 | (derive :lshl ::math-insn) 331 | (derive :lshr ::math-insn) 332 | (derive :lsub ::math-insn) 333 | (derive :lushr ::math-insn) 334 | (derive :lxor ::math-insn) 335 | 336 | (derive :dcmpg ::number-compare) 337 | (derive :lcmp ::number-compare) 338 | (derive :dcmpl ::number-compare) 339 | (derive :if_icmpne ::number-compare) 340 | 341 | (derive :iaload ::aget) 342 | (derive :saload ::aget) 343 | (derive :faload ::aget) 344 | (derive :daload ::aget) 345 | (derive :laload ::aget) 346 | (derive :caload ::aget) 347 | (derive :baload ::aget) 348 | (derive :aaload ::aget) 349 | 350 | (derive :nop ::no-op) 351 | (derive :d2f ::no-op) 352 | (derive :d2i ::no-op) 353 | (derive :f2i ::no-op) 354 | (derive :f2d ::no-op) 355 | (derive :f2l ::no-op) 356 | (derive :i2b ::no-op) 357 | (derive :i2c ::no-op) 358 | (derive :i2d ::no-op) 359 | (derive :i2f ::no-op) 360 | (derive :i2l ::no-op) 361 | (derive :i2s ::no-op) 362 | (derive :i2f ::no-op) 363 | (derive :l2f ::no-op) 364 | (derive :l2i ::no-op) 365 | (derive :l2d ::no-op) 366 | 367 | (derive :pop ::pop) 368 | (derive :pop2 ::pop) 369 | 370 | (derive :tableswitch ::select) 371 | (derive :lookupswitch ::select))) 372 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/compact.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.compact 10 | (:require [clojure.core.match :as m] 11 | [clojure.core.match.protocols :as mp] 12 | [clojure.string :as s] 13 | [clojure.walk :as w]) 14 | (:import (clojure.core.match LeafNode FailNode BindNode SwitchNode) 15 | clojure.core.match.protocols.IPatternCompile 16 | clojure.lang.ExceptionInfo)) 17 | 18 | (defn compact-sequential-destructuring [binds] 19 | (loop [[[b v :as bind] & binds] (partition 2 binds) 20 | ret []] 21 | (cond 22 | (not bind) 23 | ret 24 | 25 | (and (symbol? b) 26 | (.startsWith (name b) "seq__") 27 | (seq? v) 28 | (= `seq (first v))) 29 | (let [init (second v) 30 | placeholder b 31 | [bind binds] (loop [[[b v :as bind] & binds :as curr] binds ret []] 32 | 33 | (cond 34 | (and (symbol? b) 35 | (.startsWith (name b) "first__")) 36 | (recur binds (conj ret b)) 37 | 38 | (and (symbol? v) 39 | (.startsWith (name v) "first__")) 40 | (recur binds (replace {v b} ret)) 41 | 42 | (= v placeholder) 43 | [[(conj ret '& b) init] binds] 44 | 45 | (= b placeholder) 46 | (recur binds ret) 47 | 48 | :else 49 | [[(conj ret '& placeholder) init] curr]))] 50 | (into (into ret bind) (mapcat identity binds))) 51 | 52 | :else 53 | (recur binds (conj ret b v))))) 54 | 55 | (defn compact-vec-destructuring [binds] 56 | (loop [[[b v :as bind] & binds] (partition 2 binds) 57 | ret []] 58 | (cond 59 | (not bind) 60 | ret 61 | 62 | (and (symbol? b) 63 | (.startsWith (name b) "vec__")) 64 | (let [init v 65 | placeholder b 66 | [bind binds] (loop [[[b v :as bind] & binds :as curr] binds ret []] 67 | 68 | (cond 69 | 70 | (= v placeholder) 71 | (if (symbol? b) 72 | [[(conj ret :as b) init] binds] 73 | (recur binds b)) 74 | 75 | (and (seq? v) 76 | (= `nth (first v)) 77 | (= placeholder (second v))) 78 | (recur binds (conj ret b)) 79 | 80 | (and (seq? v) 81 | (= `nthnext (first v)) 82 | (= placeholder (second v))) 83 | [[(conj ret '& b) init] binds] 84 | 85 | :else 86 | [[ret init] curr]))] 87 | (into (into ret bind) (mapcat identity binds))) 88 | 89 | :else 90 | (recur binds (conj ret b v))))) 91 | 92 | (defn simplify-map-destructuring [m] 93 | (let [{ks true opts false} (group-by (comp keyword? val) m) 94 | {ks true oths false} (group-by #(and (not (namespace (val %))) 95 | (and (keyword? (val %)) 96 | (symbol? (key %)) 97 | (= (name (val %)) 98 | (name (key %))))) ks)] 99 | (-> {} 100 | (cond-> (seq ks) 101 | (conj [:keys (mapv key ks)])) 102 | (into opts) 103 | (into oths)))) 104 | 105 | (defn compact-associative-destructuring [binds] 106 | (loop [[[b v :as bind] & binds] (partition 2 binds) 107 | ret []] 108 | (cond 109 | (not bind) 110 | ret 111 | 112 | (and (symbol? b) 113 | (.startsWith (name b) "map__")) 114 | (let [init v 115 | placeholder b 116 | [bind binds] (loop [[[b v :as bind] & binds :as curr] (rest binds) ret {}] 117 | 118 | (cond 119 | 120 | (= v placeholder) 121 | (recur binds (assoc ret :as b)) 122 | 123 | (and (seq? v) 124 | (= `get (first v)) 125 | (= placeholder (second v))) 126 | (let [k (nth v 2) 127 | ?or (and (= 4 (count v)) (nth v 3))] 128 | (recur binds (cond-> (assoc ret b k) 129 | ?or (assoc-in [:or b] ?or)))) 130 | 131 | :else 132 | [[(simplify-map-destructuring ret) init] curr]))] 133 | (into (into ret bind) (mapcat identity binds))) 134 | 135 | :else 136 | (recur binds (conj ret b v))))) 137 | 138 | (defn remove-defrecord-methods [methods] 139 | (for [[name :as method] methods 140 | :when (not ('#{hasheq hashCode equals meta withMeta valAt getLookupThunk 141 | count empty cons equiv containsKey entryAt seq iterator 142 | assoc without size isEmpty containsValue get put 143 | remove putAll clear keySet values entrySet} 144 | name))] 145 | method)) 146 | 147 | (defn remove-defrecord-interfaces [interfaces] 148 | (remove '#{clojure.lang.IHashEq 149 | clojure.lang.IRecord 150 | clojure.lang.IObj 151 | clojure.lang.ILookup 152 | clojure.lang.IKeywordLookup 153 | clojure.lang.IPersistentMap 154 | java.util.Map 155 | java.io.Serializable} 156 | interfaces)) 157 | 158 | (defn remove-defrecord-fields [fields] 159 | (vec (remove '#{__meta __extmap __hash __hasheq} fields))) 160 | 161 | (defn register! [sym !occurs] 162 | (if (contains? @!occurs sym) 163 | (let [s (gensym (str (name sym) "_"))] 164 | (swap! !occurs update sym conj s) 165 | s) 166 | (do 167 | (swap! !occurs assoc sym #{}) 168 | sym))) 169 | 170 | (defn maybe-guard [sym guards] 171 | (if-let [guard (get guards sym)] 172 | (list sym :guard [guard]) 173 | sym)) 174 | 175 | (defn compile-pattern [form guards !occurs] 176 | (cond 177 | 178 | (seq? form) 179 | (if (and (= 'quote (first form)) 180 | (symbol? (second form))) 181 | [form] 182 | [(list (vec (mapcat #(compile-pattern % guards !occurs) form)) :seq)]) 183 | 184 | (vector? form) 185 | [(vec (mapcat #(compile-pattern % guards !occurs) form))] 186 | 187 | (symbol? form) 188 | 189 | (if (= \? (first (name form))) 190 | (let [fname (name form)] 191 | (if (= \& (second fname)) 192 | ['& (if (and (= \_ (nth fname 2)) 193 | (= 3 (count fname))) 194 | '_ 195 | (maybe-guard (register! form !occurs) guards))] 196 | (if (= \_ (second fname)) 197 | [form] 198 | [(maybe-guard (register! form !occurs) guards)]))) 199 | [(list 'quote form)]) 200 | 201 | :else 202 | [form])) 203 | 204 | (defn assert-unify [patterns] 205 | (list* `and true 206 | (for [[bind unifiers] patterns 207 | :when (seq unifiers)] 208 | `(= ~bind ~@unifiers)))) 209 | 210 | (defn cont! [f] 211 | {::cont f}) 212 | 213 | (defprotocol NodeToClj (to-clj [_])) 214 | 215 | (def ^:dynamic *conts*) 216 | 217 | (defn dag-clause-to-clj [occurrence cont pattern action] 218 | (let [test (if (instance? IPatternCompile pattern) 219 | (mp/to-source* pattern occurrence) 220 | (m/to-source pattern occurrence))] 221 | [test (to-clj (assoc action :cont cont))])) 222 | 223 | (extend-protocol NodeToClj 224 | LeafNode 225 | (to-clj [{:keys [value bindings]}] 226 | (if (not (empty? bindings)) 227 | (let [bindings (remove (fn [[sym _]] (= sym '_)) 228 | bindings)] 229 | `(let [~@(apply concat bindings)] 230 | ~value)) 231 | value)) 232 | 233 | FailNode 234 | (to-clj [{:keys [cont]}] 235 | `(cont! ~cont)) 236 | 237 | BindNode 238 | (to-clj [{:keys [bindings node cont]}] 239 | `(let [~@bindings] 240 | ~(to-clj (assoc node :cont cont)))) 241 | 242 | SwitchNode 243 | (to-clj [{:keys [occurrence cases default cont]}] 244 | (let [default-cont (when-not (instance? FailNode default) 245 | `([] ~(to-clj (assoc default :cont cont)))) 246 | 247 | _default-cont (if default-cont (gensym "default-cont_") cont) 248 | 249 | clauses (doall 250 | (mapcat (partial apply dag-clause-to-clj occurrence _default-cont) cases)) 251 | bind-expr (-> occurrence meta :bind-expr) 252 | cond-expr `(cond ~@clauses 253 | :else 254 | (cont! ~_default-cont))] 255 | 256 | (when default-cont 257 | (swap! *conts* conj (list* _default-cont default-cont))) 258 | 259 | `(let [~@(when bind-expr [occurrence bind-expr])] 260 | ~cond-expr)))) 261 | 262 | (defn run-match [f] 263 | (let [ret (f)] 264 | (if-let [cont (::cont ret)] 265 | (recur cont) 266 | ret))) 267 | 268 | (defn compile-patterns [patterns cont] 269 | (->> (for [pattern patterns 270 | :let [[pattern guards _ replacement] (if (map? (second pattern)) 271 | pattern 272 | [(first pattern) {} nil (last pattern)]) 273 | !occurs (atom {})]] 274 | [(compile-pattern pattern guards !occurs) (if (seq @!occurs) 275 | `(if ~(assert-unify @!occurs) 276 | ~replacement 277 | (cont! ~cont)) 278 | replacement)]) 279 | (mapcat identity))) 280 | 281 | (defmacro compact 282 | {:style/indent 1} 283 | [expr & patterns] 284 | (let [_expr (gensym "expr_") 285 | _cont (gensym "cont_") 286 | [patterns else] (if (= :else (last (butlast patterns))) 287 | [(-> patterns butlast butlast) (last patterns)] 288 | [patterns _expr])] 289 | 290 | (binding [m/*line* (-> &form meta :line) 291 | m/*locals* (dissoc &env '_) 292 | m/*warned* (atom false) 293 | *conts* (atom #{})] 294 | (let [init (-> (m/emit-matrix [expr] (concat (compile-patterns patterns _cont) [:else else])) 295 | m/compile 296 | (assoc :cont _cont) 297 | to-clj)] 298 | `(run-match (fn [] 299 | (let [~_expr ~expr 300 | ~_cont (fn [] ~else)] 301 | (letfn [~@@*conts*] 302 | ~init)))))))) 303 | 304 | (defn macrocompact-step [expr] 305 | (compact expr 306 | [(do ?ret) :-> ?ret] 307 | [(`let [?a ?b] (`let ?binds ?&body)) :-> `(let [~?a ~?b ~@?binds] ~@?&body)] 308 | [(fn* ?&body) :-> `(fn ~@?&body)] 309 | [(let* ?binds ?&body) :-> `(let ~?binds ~@?&body)] 310 | [(if ?test (do ?&then)) :-> `(when ~?test ~@?&then)] 311 | [(if ?test ?then nil) :->`(when ~?test ~?then)] 312 | [(`when ?test (do ?&then)) :-> `(when ~?test ~@?&then)] 313 | [(`let ?bindings (do ?&body)) :-> `(let ~?bindings ~@?&body)] 314 | [(`when-let ?bindings (do ?&body)) :-> `(when-let ~?bindings ~@?&body)] 315 | [(`when-some ?bindings (do ?&body)) :-> `(when-some ~?bindings ~@?&body)] 316 | [(`fn ?name (?bindings (do ?&body))) :-> `(fn ~?name (~?bindings ~@?&body))] 317 | [(if ?test nil ?&body) :-> `(when-not ~?test ~@?&body)] 318 | [(`when-not ?bindings (do ?&body)) :-> `(when-not ~?bindings ~@?&body)] 319 | 320 | [(clojure.lang.RT/count ?arg) :-> `(count ~?arg)] 321 | [(clojure.lang.RT/nth ?&args) :-> `(nth ~@?&args)] 322 | [(clojure.lang.RT/get ?&args) :-> `(get ~@?&args)] 323 | [(clojure.lang.RT/isReduced ?arg) :-> `(reduced? ~?arg)] 324 | [(clojure.lang.RT/alength ?arg) :-> `(alength ~?arg)] 325 | [(clojure.lang.RT/aclone ?arg) :-> `(aclone ~?arg)] 326 | [(clojure.lang.RT/aget ?arr ?idx) :-> `(aget ~?arr ~?idx)] 327 | [(clojure.lang.RT/aset ?arr ?idx ?val) :-> `(aset ~?arr ~?idx ~?val)] 328 | [(clojure.lang.RT/object_array ?arg) :-> `(object-array ~?arg)] 329 | [(clojure.lang.Util/identical ?a ?b) :-> `(identical? ~?a ~?b)] 330 | [(clojure.lang.Util/equiv ?a ?b) :-> `(= ~?a ~?b)] 331 | [(clojure.lang.Numbers/num ?a) :-> ?a] 332 | [(java.lang.Long/valueOf ?a) {?a number?} :-> (long ?a)] 333 | [(java.lang.Integer/valueOf ?a) {?a number?} :-> (int ?a)] 334 | [(java.lang.Double/valueOf ?a) {?a number?} :-> (double ?a)] 335 | [(java.lang.Float/valueOf ?a) {?a number?} :-> (float ?a)] 336 | 337 | [(.get (var ?v)) :-> ?v] 338 | 339 | [(`-> ?&x) 340 | :-> 341 | `(-> ~@(mapcat (fn [x] 342 | (compact x 343 | [(`-> ?&y) :-> `[~@?&y]] 344 | :else [x])) 345 | ?&x))] 346 | 347 | [(do ?&body) 348 | {?&body #(some (fn [expr] 349 | (and (seq? expr) 350 | (= 'do (first expr)))) 351 | %)} 352 | :-> 353 | (list* 'do (->> (for [expr ?&body 354 | :when expr] 355 | (if (and (seq? expr) 356 | (= 'do (first expr))) 357 | (rest expr) 358 | [expr])) 359 | (mapcat identity)))] 360 | 361 | [(clojure.lang.Var/pushThreadBindings ?binds) :-> `(push-thread-bindings ~?binds)] 362 | [(clojure.lang.Var/popThreadBindings) :-> `(pop-thread-bindings)] 363 | 364 | [(do (`push-thread-bindings ?binds) 365 | (try 366 | ?&body)) 367 | {?&body #(= `(finally (pop-thread-bindings)) (last %))} 368 | :-> 369 | (let [?&body (butlast ?&body)] 370 | (cond 371 | 372 | (map? ?binds) 373 | (if (every? #(and (seq? %) (= 'var (first %))) (keys ?binds)) 374 | `(binding ~(vec (mapcat (fn [[[_ var] init]] [var init]) ?binds)) ~@?&body) 375 | `(with-bindings ~?binds ~@?&body)) 376 | 377 | (and (seq? ?binds) (= `hash-map (first ?binds))) 378 | (if (every? #(and (seq? %) (= 'var (first %))) (take-nth 2 (rest ?binds))) 379 | `(binding ~(vec (mapcat (fn [[[_ var] init]] [var init]) (partition 2 (rest ?binds)))) ~@?&body) 380 | `(with-bindings ~?binds ~@?&body)) 381 | 382 | :else 383 | `(with-bindings ~?binds ~@?&body)))] 384 | 385 | [(`with-bindings ?bindings ?&body) 386 | {?bindings #(and (map? %) 387 | (contains? % 'clojure.lang.Compiler/LOADER) 388 | (= 1 (count %)))} 389 | :-> 390 | `(with-loading-context ~@?&body)] 391 | 392 | [(`identical? ?x nil) :-> `(nil? ~?x)] 393 | [(`identical? nil ?x) :-> `(nil? ~?x)] 394 | 395 | [(clojure.lang.LazySeq. (`fn ?_ ([] ?&body))) :-> `(lazy-seq ~@?&body)] 396 | [(clojure.lang.Delay. (`fn ?_ ([] ?&body))) :-> `(delay ~@?&body)] 397 | [(`bound-fn* (`fn ?_ ([] ?&body))) :-> `(bound-fn ~@?&body)] 398 | 399 | [(.reset ?v (?f (.deref ?v) ?&args)) :-> `(vswap! ~?v ~?f ~@?&args)] 400 | 401 | [(`when-not (.equals ?ns ''clojure.core) 402 | (`dosync ?&_) 403 | nil) 404 | :-> 405 | nil] 406 | 407 | [(if ?test1 ?then1 (`when ?test2 ?&then2)) :-> `(cond ~?test1 ~?then1 ~?test2 (do ~@?&then2))] 408 | [(if ?test1 ?then1 (`cond ?&body)) :-> `(cond ~?test1 ~?then1 ~@?&body)] 409 | 410 | [(loop* ?&l) :-> `(loop ~@?&l)] 411 | 412 | [(`let [?a ?b] (try ?&body)) 413 | {?&body #(and (seq? %) 414 | (compact (last %) 415 | [(finally (.close ?x)) :-> true] 416 | :else false))} 417 | :-> 418 | `(with-open [~?a ~?b] 419 | ~@(butlast ?&body))] 420 | 421 | ;; no :let/:when/:while support 422 | [(`loop [?seq (`seq ?b) ?chunk nil ?count 0 ?i 0] 423 | (if (`< ?i ?count) 424 | (`let [?a (.nth ?chunk ?i) 425 | ?&binds] 426 | ?&body) 427 | (`when-let [?seq (`seq ?seq)] 428 | (if (`chunked-seq? ?seq) 429 | (`let [?c (`chunk-first ?seq)] 430 | (recur ?&_)) 431 | (`let [?x (`first ?seq) ?&_] ?&_))))) 432 | {?&body #(and (seq? (last %)) 433 | (= 'recur (-> % last first))) 434 | ?&binds #(empty? %)} 435 | :-> `(doseq [~?a ~?b] ~@(butlast ?&body))] 436 | 437 | [(`let [?c ?t] 438 | (`loop [?n 0] 439 | (`when (`< ?n ?c) 440 | ?&body))) 441 | {?body #(compact % [(recur (`inc ?a)) :-> true] :else false)} 442 | :-> 443 | `(dotimes [~?n ~?t] 444 | ~@(butlast ?&body))] 445 | 446 | [(`let [?l ?lock] 447 | (try 448 | (do (monitor-enter ?l) 449 | ?&body) 450 | (finally ?&_))) 451 | :-> 452 | `(locking ~?lock ~@?&body)] 453 | 454 | [(`let [?x ?y] 455 | (`when ?x 456 | (`let [?z ?x ?&binds] ?&body))) 457 | {?x #(and (symbol? %) (-> % name (.startsWith "temp__")))} 458 | :-> 459 | (let [body (if (empty? ?&binds) `(do ~@?&body) `(let [~@?&binds] ~@?&body))] 460 | `(when-let [~?z ~?y] ~body))] 461 | 462 | [(`let [?x ?y] 463 | (if ?x 464 | (`let [?z ?x ?&binds] ?&body) 465 | ?else)) 466 | {?x #(and (symbol? %) (-> % name (.startsWith "temp__")))} 467 | :-> 468 | (let [body (if (empty? ?&binds) `(do ~@?&body) `(let [~@?&binds] ~@?&body))] 469 | `(if-let [~?z ~?y] ~body ~?else))] 470 | 471 | [(`let [?x ?y] 472 | (if (`nil? ?x) 473 | nil 474 | (`let [?z ?x ?&binds] ?&body))) 475 | {?x #(and (symbol? %) (-> % name (.startsWith "temp__")))} 476 | :-> 477 | (let [body (if (empty? ?&binds) `(do ~@?&body) `(let [~@?&binds] ~@?&body))] 478 | `(when-some [~?z ~?y] ~body))] 479 | 480 | [(`let [?x ?y] 481 | (if (`nil? ?x) 482 | ?else 483 | (`let [?z ?x] 484 | ?&body))) 485 | {?x #(and (symbol? %) (-> % name (.startsWith "temp__")))} 486 | :-> 487 | `(if-some [~?z ~?y] (do ~@?&body) ~?else)] 488 | 489 | [(`let [?t ?x] (if ?t ?y ?t)) 490 | {?t #(and (symbol? %) (-> % name (.startsWith "and__")))} 491 | :-> 492 | `(and ~?x ~?y)] 493 | [(`and ?x (`and ?y ?&z)) :-> `(and ~?x ~?y ~@?&z)] 494 | 495 | [(`let [?t ?x] (if ?t ?t ?y)) 496 | {?t #(and (symbol? %) (-> % name (.startsWith "or__")))} 497 | :-> 498 | `(or ~?x ~?y)] 499 | [(`or ?x (`or ?y ?&z)) :-> `(or ~?x ~?y ~@?&z)] 500 | 501 | ;; specialise for two for now 502 | [(`defn ?n ([?x ?&xs] (`let [?x_d ?x ?&binds] ?&body))) 503 | {?x #(and (symbol? %) (-> % name (.startsWith "p__")))} 504 | :-> 505 | `(defn ~?n 506 | ([~?x_d ~@?&xs] 507 | (let [~@?&binds] ~@?&body)))] 508 | [(`defn ?n ([?a ?x ?&xs] (`let [?x_d ?x ?&binds] ?&body))) 509 | {?x #(and (symbol? %) (-> % name (.startsWith "p__")))} 510 | :-> 511 | `(defn ~?n 512 | ([~?a ~?x_d ~@?&xs] 513 | (let [~@?&binds] ~@?&body)))] 514 | 515 | ;; WIP body should not use ?n 516 | [((`fn ?n ([] ?&body))) :-> `(do ~@?&body)] 517 | 518 | [(clojure.core/import* ?klass) :-> `(import '~(symbol ?klass))] 519 | 520 | [(.setMeta ?ref ?meta) :-> `(reset-meta! ~?ref ~?meta)] 521 | [(`reset-meta! ?var ?meta) {?meta #(and (map? %) 522 | (empty? (dissoc % :file :line :column :arglists :doc)))} :-> nil] 523 | 524 | [(`reset-meta! ?var ?meta) {?meta #(and (map? %) (:declared %))} :-> `(declare ~(-> ?var second))] 525 | 526 | [(.withMeta (`list ?&body) ?meta) {?meta #(and (map? %) (#{#{:line} #{:column} #{:line :column}} (set (keys %))))} :-> `(list ~@?&body)] 527 | [(.withMeta ?x ?meta) {?meta #(and (map? %) (empty? %))} :-> ?x] 528 | 529 | [(clojure.lang.LockingTransaction/runInTransaction (`fn ?_ ([] ?&body))) :-> `(dosync ~@?&body)] 530 | 531 | ;; WIP custom message 532 | [(if (clojure.lang.LockingInTransaction/isRunning) 533 | (throw ?_) 534 | ?body) :-> `(io! ~?body)] 535 | 536 | [(`when-let [?bind (`seq ?xs)] 537 | (`let [?x ?bind] 538 | ?&body)) {?bind #(and (symbol? %) (-> % name (.startsWith "xs__")))} 539 | :-> 540 | `(when-first [~?x ~?xs] 541 | ~@?&body)] 542 | 543 | [(`when-not (`nil? ?g) 544 | (?f ?g ?&args)) 545 | {?g #(and (symbol? %) (-> % name (.startsWith "G__")))} 546 | :-> `(some-> ~?g (~?f ~@?&args))] 547 | 548 | [(`let [?g (`some-> ?g ?&exprs)] 549 | (`some-> ?g ?&exprs2)) 550 | :-> `(some-> ~?g ~@?&exprs ~@?&exprs2)] 551 | 552 | [(`let [?g ?expr] 553 | (`some-> ?g ?&exprs2)) 554 | :-> `(some-> ~?expr ~@?&exprs2)] 555 | 556 | [(`if ?test 557 | (?f ?g ?&args) 558 | ?g) 559 | {?g #(and (symbol? %) (-> % name (.startsWith "G__")))} 560 | :-> `(cond-> ~?g ~?test (~?f ~@?&args))] 561 | 562 | [(`let [?g (`cond-> ?g ?&exprs)] 563 | (`cond-> ?g ?&exprs2)) 564 | :-> `(cond-> ~?g ~@?&exprs ~@?&exprs2)] 565 | 566 | [(`let [?g ?expr] 567 | (`cond-> ?g ?&exprs2)) 568 | :-> `(cond-> ~?expr ~@?&exprs2)] 569 | 570 | [(do 571 | nil 572 | (`let [?v (var ?var)] 573 | (`when-not (`and (.hasRoot ?v) 574 | (`instance? clojure.lang.MultiFn (`deref ?v))) 575 | ?_ 576 | (def ?name (clojure.lang.MultiFn. ?sname ?dispatch-fn ?d ?h)) 577 | (var ?var)))) 578 | :-> 579 | `(defmulti ~?name ~?dispatch-fn 580 | ~@(when-not (= ?d :default) [?d]) 581 | ~@(when-not (= ?h '(var clojure.core/global-hierarchy)) [?h]))] 582 | 583 | [(`let [?s (java.io.StringWriter.)] 584 | (`binding [`*out* ?s] 585 | ?&body)) 586 | {?&body #(compact (last %) [(`str ?_) :-> true] :else false)} 587 | :-> `(with-out-str ~@(butlast ?&body))] 588 | 589 | [(`let [?s (clojure.lang.LineNumberingPushbackReader. (java.io.StringReader. ?i))] 590 | (`binding [`*in* ?s] 591 | ?&body)) 592 | :-> `(with-in-str ~@?&body)] 593 | 594 | [(clojure.lang.RT/classForName ?class) {?class string?} :-> (symbol ?class)] 595 | 596 | [(`refer ''clojure.core ?&filters) :-> `(refer-clojure ~@?&filters)] 597 | 598 | [(`let [?v (var ?var)] 599 | (`when-not (.hasRoot ?v) 600 | ?_ 601 | (def ?name ?expr) 602 | (var ?var))) :-> `(defonce ~?name ~?expr)] 603 | 604 | [(`loop [] 605 | (`when ?test 606 | ?&body)) 607 | {?&body #(= '(recur) (last %))} 608 | :-> 609 | `(while ~?test ~@(butlast ?&body))] 610 | 611 | [(.addMethod ?multi ?dispatch-val (`fn ?&body)) :-> `(defmethod ~?multi ~?dispatch-val ~@?&body)] 612 | 613 | [(letfn* ?binds ?&body) :-> `(letfn ~(vec (for [[_ bind] (partition 2 ?binds)] 614 | (rest bind))) 615 | ~@?&body)] 616 | 617 | [(`future-call (fn ?_ [] ?&body)) :-> `(future ~@?&body)] 618 | 619 | [(reify* ?interfaces ?&methods) :-> `(reify ~@?interfaces ~@?&methods)] 620 | [(.withMeta (`reify ?&body) ?_) :-> `(reify ~@?&body)] 621 | 622 | [(`let [?p (?ctor)] 623 | (`init-proxy ?p ?methods-map) 624 | ?p) :-> 625 | `(proxy ~(-> ?ctor str (s/split #"\$") (rest) (butlast) (->> (mapv symbol))) 626 | ~@(for [[method method-fn] ?methods-map] 627 | (list* (symbol method) (drop 2 method-fn))))] 628 | 629 | [(`proxy-call-with-super (`fn ?_ ([] ?meth)) ?&_) 630 | {?meth #(= 'this (second %) )} 631 | :-> `(proxy-super ~(-> ?meth first str (subs 1) symbol) ~@(->> ?meth (drop 2)))] 632 | 633 | [(`+ ?a 1) :-> `(inc ~?a)] 634 | [(`+ 1 ?a) :-> `(inc ~?a)] 635 | [(`- ?a 1) :-> `(dec ~?a)] 636 | 637 | [(`let [?a ?arr, ?ret (`aclone ?a)] 638 | (`loop [?idx 0] 639 | (if (`< ?idx (`alength ?a)) 640 | (do 641 | (`aset ?ret (java.lang.Integer/valueOf ?idx) ?expr) 642 | (recur (`inc ?idx))) 643 | ?ret))) 644 | :-> `(amap ~?arr ~?idx ~?ret ~?expr)] 645 | 646 | [(`case ?&exprs) 647 | {?&exprs #(and (even? (count %)) 648 | (compact (last %) 649 | [(do (throw (java.lang.IllegalArgumentException. (`str "No matching clause: " ?_))) ?&_) :-> true] 650 | :else false))} 651 | :-> `(case ~@(butlast ?&exprs))] 652 | 653 | [(`let [?g ?expr] 654 | (`case ?g 655 | ?&body)) 656 | {?g #(and (symbol? %) (-> % name (.startsWith "G__")))} 657 | :-> `(case ~?expr ~@?&body)] 658 | 659 | [(`let [?a ?arr ?len (`alength ?a)] 660 | (`loop [?idx 0, ?ret ?init] 661 | (if (`< ?idx ?len) (recur (`inc ?idx) ?expr) ?ret))) 662 | :-> `(areduce ~?arr ~?idx ~?ret ~?init ~?expr)] 663 | 664 | [(`let [?x ?obj] (?f ?x ?&args) (?g ?x ?&args2) ?&exprs) 665 | {?x #(and (symbol? %) (-> % name (.startsWith "G__"))) 666 | ?&exprs (fn [exprs] (every? #(and (seq? %) (= (last exprs) (second %))) (butlast exprs)))} 667 | :-> `(doto ~?obj (~?f ~@?&args) (~?g ~@?&args2) ~@(map #(list* (first %) (drop 2 %)) (butlast ?&exprs)))] 668 | 669 | [(deftype* ?record ?rtype ?argv :implements ?interfaces ?&impls) 670 | {?interfaces #(some #{'clojure.lang.IRecord} %)} 671 | 672 | :-> `(defrecord ~(symbol (name ?record)) ~(remove-defrecord-fields ?argv) 673 | ~@(remove-defrecord-interfaces ?interfaces) ~@(remove-defrecord-methods ?&impls))] 674 | [(do 675 | nil 676 | (var ?_) 677 | nil 678 | (var ?__) 679 | (`defrecord ?&body) 680 | ?&_) 681 | :-> `(defrecord ~@?&body)] 682 | 683 | [(`alter-meta! (var ?v) `assoc :doc nil) :-> nil] 684 | [((var clojure.core/assert-same-protocol) ?&_) :-> nil] 685 | [(`-reset-methods ?_) :-> nil] 686 | [(`alter-var-root (var ?p) `merge (`assoc ?m :sigs ?sigs :var (var ?p) :method-map ?mm :method-builders ?mb)) 687 | :-> `(defprotocol ~(symbol (name ?p)) 688 | ~@(->> (for [[f {:keys [arglists]}] ?sigs] 689 | [(symbol (name f)) (map #(mapv second (if (vector? %) % (second %))) (rest arglists))]) 690 | (mapcat identity)))] 691 | 692 | [(deftype* ?type ?ttype ?argv :implements ?interfaces ?&impls) 693 | {?interfaces #(some #{'clojure.lang.IType} %)} 694 | 695 | :-> `(deftype ~(symbol (name ?type)) ~?argv 696 | ~@(remove #{'clojure.lang.IType} ?interfaces) ~@?&impls)] 697 | 698 | [(do (deftype ?&body) ?&_) :-> `(deftype ~@?&body)] 699 | 700 | [(`let [?&binds] ?&body) 701 | {?&binds (fn [binds] (some #(and (symbol? (first %)) 702 | (.startsWith (name (first %)) "map__") 703 | (compact (second %) 704 | [(if (`seq? ?m) 705 | (clojure.lang.PersistentHashMap/create (`seq ?m)) 706 | ?m) :-> false] 707 | :else true)) 708 | (partition 2 binds)))} 709 | :-> 710 | `(let [~@(compact-associative-destructuring ?&binds)] ~@?&body)] 711 | 712 | [(`let [?&binds] ?&body) 713 | {?&binds (fn [binds] (some #(and (symbol? (first %)) 714 | (.startsWith (name (first %)) "seq__") 715 | (seq? (second %)) 716 | (= `seq (first (second %)))) 717 | (partition 2 binds)))} 718 | :-> 719 | `(let [~@(compact-sequential-destructuring ?&binds)] ~@?&body)] 720 | 721 | [(`let [?&binds] ?&body) 722 | {?&binds (fn [binds] (some #(and (symbol? %) (.startsWith (name %) "vec__")) (take-nth 2 binds)))} 723 | :-> 724 | `(let [~@(compact-vec-destructuring ?&binds)] ~@?&body)] 725 | 726 | [(.set (var ?v) ?val) ?-> `(set! ~?v ~?val)] 727 | 728 | [(.bindRoot (var ?var) (`fn ?name ?&body)) :-> `(defn ~(-> ?var name symbol) ~@?&body)] 729 | [(.bindRoot (var ?var) ?val) :-> `(def ~(-> ?var name symbol) ~?val)])) 730 | 731 | ;; WIP for, assert, ns, condp, with-redefs, definterface 732 | 733 | (defn macrocompact [source] 734 | (w/postwalk 735 | (fn [node] 736 | (if (seq? node) 737 | (let [new-node (macrocompact-step node)] 738 | (if (= node new-node) 739 | node 740 | (recur new-node))) 741 | node)) 742 | source)) 743 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/pprint.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.pprint 10 | (:require [clojure.walk :as w] 11 | [fipp.clojure :as fp])) 12 | 13 | (defn ->pprint-str [source] 14 | (with-out-str (fp/pprint source {:width 100}))) 15 | 16 | (defn elide-ns [source] 17 | (let [!aliases (atom {}) 18 | w (fn [f s] (w/walk f identity s)) 19 | f (fn f [x] 20 | 21 | (cond 22 | (seq? x) 23 | (if (= 'quote (first x)) 24 | x 25 | (do 26 | (when (and (= 'clojure.core/in-ns (first x)) 27 | (seq? (second x)) 28 | (= 'quote (-> x second first))) 29 | (let [ns (-> x second second) 30 | ns (if (list? ns) (second ns) ns)] 31 | (swap! !aliases assoc (name ns) ""))) 32 | 33 | (when (= 'clojure.core/refer-clojure (first x)) 34 | (let [ex (->> x (drop-while (complement #{:exclude})) second) 35 | ex (if (vector? ex) ex (rest ex))] 36 | (swap! !aliases assoc "clojure.core" (->> ex (map (comp str second)) (into #{}))))) 37 | 38 | (when (= 'clojure.core/import (first x)) 39 | (doseq [[_ k] (rest x)] 40 | (swap! !aliases assoc (str k) 41 | (clojure.string/replace (str k) #".*\.([^.]+)" "$1")))) 42 | 43 | (when (= 'clojure.core/require (first x)) 44 | (doseq [req (rest x) 45 | :when (vector? req)] 46 | (when-let [alias (some->> req (drop-while (complement #{:as})) second second name)] 47 | (let [ns (some-> req first second name)] 48 | (when-not (= ns "clojure.core") 49 | (swap! !aliases assoc ns alias)))))) 50 | (w f x))) 51 | 52 | (symbol? x) 53 | (let [aliases @!aliases] 54 | (if (= "clojure.core" (namespace x)) 55 | (if (contains? (get aliases "clojure.core") (name x)) 56 | x 57 | (symbol (name x))) 58 | (if-let [alias (get aliases (namespace x))] 59 | (if (= "" alias) 60 | (symbol (name x)) 61 | (symbol (str alias "/" (name x)))) 62 | x))) 63 | 64 | :else 65 | (w f x)))] 66 | (w f source))) 67 | 68 | (defn pprint [source] 69 | (-> source 70 | (elide-ns) 71 | (->> (keep identity) 72 | (remove #(and (seq? %) (= 'var (first %))))) 73 | (->pprint-str))) 74 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/source.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.source 10 | (:require [clojure.tools.decompiler.utils :refer [demunge]])) 11 | 12 | (defmulti ast->clj :op) 13 | 14 | (defmethod ast->clj :const [{:keys [val]}] 15 | val) 16 | 17 | (defmethod ast->clj :case [{:keys [shift mask default type switch-type skip-check exprs test]}] 18 | `(case ~(ast->clj test) 19 | ~@(->> (for [[type match test expr] exprs] 20 | (if (= :collision type) 21 | (mapcat (fn [[test expr]] 22 | (let [test (ast->clj test) 23 | test (if (seq? test) 24 | (second test) 25 | test)] 26 | [test (ast->clj expr)])) 27 | test) 28 | [(ast->clj test) (ast->clj expr)])) 29 | (group-by second) 30 | (mapcat (fn [[then tests+thens]] 31 | (let [tests (map first tests+thens) 32 | test (if (= 1 (count tests)) 33 | (first tests) 34 | tests)] 35 | [test then])))) 36 | ~(ast->clj default))) 37 | 38 | (defmethod ast->clj :monitor-enter [{:keys [sentinel]}] 39 | `(monitor-enter ~(ast->clj sentinel))) 40 | 41 | (defmethod ast->clj :monitor-exit [{:keys [sentinel]}] 42 | `(monitor-exit ~(ast->clj sentinel))) 43 | 44 | (defmethod ast->clj :do [{:keys [statements ret]}] 45 | `(do ~@(map ast->clj statements) ~(ast->clj ret))) 46 | 47 | (defmethod ast->clj :local-variable [{:keys [local-variable init]}] 48 | `[~(ast->clj local-variable) ~(ast->clj init)]) 49 | 50 | (defmethod ast->clj :let [{:keys [local-variables body]}] 51 | `(let* [~@(mapcat ast->clj local-variables)] ~(ast->clj body))) 52 | 53 | (defmethod ast->clj :letfn [{:keys [local-variables body]}] 54 | `(letfn* ~(->> (for [{:keys [local-variable init]} local-variables] 55 | [(symbol (:name local-variable)) 56 | `(fn* ~(symbol (:name local-variable)) 57 | ~@(first (drop-while (complement sequential?) (ast->clj init))))]) 58 | (mapcat identity) 59 | (vec)) 60 | ~(ast->clj body))) 61 | 62 | (defmethod ast->clj :method [{:keys [name args body]}] 63 | `(~(demunge name) [~@(map (comp symbol :name) args)] ~(ast->clj body))) 64 | 65 | (defmethod ast->clj :reify [{:keys [interfaces methods]}] 66 | `(reify* ~(mapv symbol interfaces) 67 | ~@(map ast->clj methods))) 68 | 69 | (defmethod ast->clj :import [{:keys [class]}] 70 | `(clojure.core/import* ~class)) 71 | 72 | ;; WIP meta 73 | (defmethod ast->clj :deftype [{:keys [name tname fields interfaces methods]}] 74 | `(deftype* ~(symbol tname) ~(symbol name) 75 | ~(mapv (comp symbol :name) fields) 76 | :implements ~(mapv symbol interfaces) 77 | ~@(map ast->clj methods))) 78 | 79 | (defmethod ast->clj :loop [{:keys [local-variables body]}] 80 | `(loop* [~@(mapcat ast->clj local-variables)] ~(ast->clj body))) 81 | 82 | (defmethod ast->clj :if [{:keys [test then else]}] 83 | `(if ~@(map ast->clj [test then else]))) 84 | 85 | (defmethod ast->clj :set! [{:keys [target val]}] 86 | `(set! ~(ast->clj target) ~(ast->clj val))) 87 | 88 | (defmethod ast->clj :throw [{:keys [ex]}] 89 | `(throw ~(ast->clj ex))) 90 | 91 | (defmethod ast->clj :new [{:keys [class args]}] 92 | `(~(symbol (str class ".")) ~@(map ast->clj args))) 93 | 94 | (defmethod ast->clj :instance-field [{:keys [instance field]}] 95 | `(~(demunge (str ".-" field)) ~(ast->clj instance))) 96 | 97 | (defmethod ast->clj :local [{:keys [name]}] 98 | (symbol name)) 99 | 100 | (defmethod ast->clj :recur [{:keys [args]}] 101 | `(recur ~@(map ast->clj args))) 102 | 103 | (defmethod ast->clj :vector [{:keys [items]}] 104 | (mapv ast->clj items)) 105 | 106 | (defmethod ast->clj :list [{:keys [items]}] 107 | `(list ~@(map ast->clj items))) 108 | 109 | (defmethod ast->clj :set [{:keys [items]}] 110 | (into #{} (map ast->clj) items)) 111 | 112 | (defmethod ast->clj :map [{:keys [items]}] 113 | (into {} (map vec (partition 2 (map ast->clj items))))) 114 | 115 | (defmethod ast->clj :array [{:keys [!items]}] 116 | (object-array (mapv ast->clj @!items))) 117 | 118 | (defmethod ast->clj :fn [{:keys [fn-methods name]}] 119 | ;; wip meta, fn name 120 | `(fn* ~(symbol name) ~@(map ast->clj fn-methods))) 121 | 122 | (defmethod ast->clj :fn-method [{:keys [args body var-args?]}] 123 | ;; wip tags 124 | (let [argv (mapv (comp symbol :name) args) 125 | argv (if var-args? 126 | (into (pop argv) ['& (peek argv)]) 127 | argv)] 128 | `(~argv ~(ast->clj body)))) 129 | 130 | (defmethod ast->clj :static-field [{:keys [target field]}] 131 | (symbol target field)) 132 | 133 | (defmethod ast->clj :invoke-static [{:keys [target method args]}] 134 | `(~(symbol target method) ~@(map ast->clj args))) 135 | 136 | (defmethod ast->clj :invoke-instance [{:keys [target method args]}] 137 | `(~(demunge (str "." method)) ~(ast->clj target) ~@(map ast->clj args))) 138 | 139 | (defmethod ast->clj :var [{:keys [ns name]}] 140 | (symbol ns name)) 141 | 142 | (defmethod ast->clj :the-var [{:keys [ns name]}] 143 | `(var ~(symbol ns name))) 144 | 145 | (defmethod ast->clj :invoke [{:keys [fn args]}] 146 | `(~(ast->clj fn) ~@(map ast->clj args))) 147 | 148 | (defmethod ast->clj :catch [{:keys [local body]}] 149 | `(catch ~(symbol (:type local)) ~(symbol (:name local)) ~(ast->clj body))) 150 | 151 | (defmethod ast->clj :try [{:keys [body catches finally]}] 152 | `(try ~(ast->clj body) 153 | ~@(when catches 154 | (mapv ast->clj catches)) 155 | ~@(when finally 156 | [`(finally ~(ast->clj finally))]))) 157 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/sugar.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.sugar 10 | (:require [clojure.tools.decompiler.utils :as u] 11 | [clojure.edn :as e])) 12 | 13 | ;; WIP this could use a postwalk 14 | 15 | (defmulti ast->sugared-ast* :op) 16 | 17 | (defmethod ast->sugared-ast* :const [ast] 18 | ast) 19 | 20 | (defmethod ast->sugared-ast* :list [ast] 21 | (-> ast 22 | (update :items #(mapv ast->sugared-ast* %)))) 23 | 24 | (defmethod ast->sugared-ast* :map [ast] 25 | (-> ast 26 | (update :items #(mapv ast->sugared-ast* %)))) 27 | 28 | (defmethod ast->sugared-ast* :case [ast] 29 | (-> ast 30 | (update :test ast->sugared-ast*) 31 | (update :default ast->sugared-ast*) 32 | (update :exprs #(mapv (fn [[type match test expr]] 33 | [type match (if (= :collision type) 34 | (mapv (fn [[test expr]] 35 | [(ast->sugared-ast* test) 36 | (ast->sugared-ast* expr)]) 37 | test) 38 | (ast->sugared-ast* test)) 39 | (ast->sugared-ast* expr)]) 40 | %)))) 41 | 42 | (defmethod ast->sugared-ast* :local-variable [ast] 43 | (-> ast 44 | (update :init ast->sugared-ast*))) 45 | 46 | (defmethod ast->sugared-ast* :try [{:keys [finally catches] :as ast}] 47 | (-> ast 48 | (update :body ast->sugared-ast*) 49 | (cond-> finally 50 | (update :finally ast->sugared-ast*)) 51 | (cond-> catches 52 | (update :catches #(mapv ast->sugared-ast* %))))) 53 | 54 | (defmethod ast->sugared-ast* :catch [ast] 55 | (-> ast 56 | (update :body ast->sugared-ast*))) 57 | 58 | (defmethod ast->sugared-ast* :method [ast] 59 | (-> ast 60 | (update :body ast->sugared-ast*))) 61 | 62 | (defmethod ast->sugared-ast* :reify [ast] 63 | (-> ast 64 | (update :methods #(mapv ast->sugared-ast* %)))) 65 | 66 | (defmethod ast->sugared-ast* :deftype [ast] 67 | (-> ast 68 | (update :methods #(mapv ast->sugared-ast* %)))) 69 | 70 | (defmethod ast->sugared-ast* :let [ast] 71 | (-> ast 72 | (update :local-variables #(mapv ast->sugared-ast* %)) 73 | (update :body ast->sugared-ast*))) 74 | 75 | (defmethod ast->sugared-ast* :letfn [ast] 76 | (-> ast 77 | (update :local-variables #(mapv ast->sugared-ast* %)) 78 | (update :body ast->sugared-ast*))) 79 | 80 | (defmethod ast->sugared-ast* :set! [ast] 81 | (-> ast 82 | (update :target ast->sugared-ast*) 83 | (update :val ast->sugared-ast*))) 84 | 85 | (defmethod ast->sugared-ast* :loop [ast] 86 | (-> ast 87 | (update :local-variables #(mapv ast->sugared-ast* %)) 88 | (update :body ast->sugared-ast*))) 89 | 90 | (defmethod ast->sugared-ast* :new [ast] 91 | (-> ast 92 | (update :args #(mapv ast->sugared-ast* %)))) 93 | 94 | (defmethod ast->sugared-ast* :throw [ast] 95 | (-> ast 96 | (update :ex ast->sugared-ast*))) 97 | 98 | (defmethod ast->sugared-ast* :monitor-enter [ast] 99 | ast) 100 | 101 | (defmethod ast->sugared-ast* :monitor-exit [ast] 102 | ast) 103 | 104 | (defmethod ast->sugared-ast* :do [ast] 105 | (let [{:keys [statements ret] :as ast} (-> ast 106 | (update :statements #(mapv ast->sugared-ast* %)) 107 | (update :ret ast->sugared-ast*))] 108 | (if (empty? statements) 109 | ret 110 | ast))) 111 | 112 | (defmethod ast->sugared-ast* :if [ast] 113 | (-> ast 114 | (update :test ast->sugared-ast*) 115 | (update :then ast->sugared-ast*) 116 | (update :else ast->sugared-ast*))) 117 | 118 | (defmethod ast->sugared-ast* :set [ast] 119 | ast) 120 | 121 | (defmethod ast->sugared-ast* :recur [ast] 122 | (-> ast 123 | (update :args #(mapv ast->sugared-ast* %)))) 124 | 125 | (defmethod ast->sugared-ast* :vector [ast] 126 | ast) 127 | 128 | (defmethod ast->sugared-ast* :array [{:keys [!items] :as ast}] 129 | (swap! !items #(mapv ast->sugared-ast* %)) 130 | ast) 131 | 132 | (defmethod ast->sugared-ast* :local [ast] 133 | ast) 134 | 135 | (defmethod ast->sugared-ast* :var [ast] 136 | ast) 137 | 138 | (defmethod ast->sugared-ast* :the-var [ast] 139 | ast) 140 | 141 | (defmethod ast->sugared-ast* :instance-field [ast] 142 | (-> ast 143 | (update :instance ast->sugared-ast*))) 144 | 145 | (defmethod ast->sugared-ast* :static-field [{:keys [target field] :as ast}] 146 | (cond 147 | (and (#{"clojure.lang.PersistentList" "clojure.lang.PersistentVector" 148 | "clojure.lang.PersistentArrayMap" "clojure.lang.PersistentHashSet"} target) 149 | (= "EMPTY" field)) 150 | {:op :const 151 | :val (case target 152 | "clojure.lang.PersistentList" () 153 | "clojure.lang.PersistentVector" [] 154 | "clojure.lang.PersistentArrayMap" {} 155 | "clojure.lang.PersistentHashSet" #{})} 156 | 157 | (and (= target "java.lang.Boolean") 158 | (#{"TRUE" "FALSE"} field)) 159 | {:op :const 160 | :val (case field "TRUE" true "FALSE" false)} 161 | 162 | :else 163 | ast)) 164 | 165 | (defmethod ast->sugared-ast* :invoke [ast] 166 | (let [ast (-> ast 167 | (update :args #(mapv ast->sugared-ast* %)) 168 | (update :fn ast->sugared-ast*))] 169 | (if (and (-> ast :args first :op (= :invoke)) 170 | (-> ast :args first :args first :op (= :invoke)) 171 | (-> ast :args first :args first :args first :op (= :invoke)) 172 | (-> ast :args first :args first :args first :args first :op (= :invoke))) 173 | {:op :invoke 174 | :fn {:op :var :ns "clojure.core" :name "->"} 175 | :args [(-> ast :args first :args first :args first :args first) 176 | {:op :invoke 177 | :fn (-> ast :args first :args first :args first :fn) 178 | :args (-> ast :args first :args first :args first :args rest vec)} 179 | {:op :invoke 180 | :fn (-> ast :args first :args first :fn) 181 | :args (-> ast :args first :args first :args rest vec)} 182 | {:op :invoke 183 | :fn (-> ast :args first :fn) 184 | :args (-> ast :args first :args rest vec)} 185 | {:op :invoke 186 | :fn (-> ast :fn) 187 | :args (-> ast :args rest vec)}]} 188 | ast))) 189 | 190 | (defmethod ast->sugared-ast* :fn [ast] 191 | (-> ast 192 | (update :fn-methods #(mapv ast->sugared-ast* %)))) 193 | 194 | (defmethod ast->sugared-ast* :fn-method [ast] 195 | (-> ast 196 | (update :body ast->sugared-ast*))) 197 | 198 | (defmethod ast->sugared-ast* :import [ast] ast) 199 | 200 | (defmethod ast->sugared-ast* :invoke-instance [{:keys [method target-class] :as ast}] 201 | (let [{:keys [target args] :as ast} (-> ast 202 | (update :target ast->sugared-ast*) 203 | (update :args #(mapv ast->sugared-ast* %)))] 204 | (cond 205 | 206 | (or (and (= target-class "clojure.lang.IFn") 207 | (= "invoke" method)) 208 | (= "invokePrim" method)) 209 | 210 | {:op :invoke 211 | :fn target 212 | :args args} 213 | 214 | (and (= target-class "clojure.lang.Var") 215 | (#{"getRoot" "getRawRoot"} method) 216 | (= (:op target) :the-var)) 217 | 218 | {:op :var 219 | :name (:name target) 220 | :ns (:ns target)} 221 | 222 | ;; WIP better match 223 | (and (= method "importClass") 224 | (= (:method target) "deref")) 225 | {:op :import 226 | :class (-> args first :args first :val)} 227 | 228 | :else 229 | ast))) 230 | 231 | (def math-ops 232 | {"add" "+" 233 | "addP" "+'" 234 | "and" "bit-and" 235 | "andNot" "bit-and-not" 236 | "clearBit" "bit-clear" 237 | "dec" "dec" 238 | "decP" "dec" 239 | "divide" "/" 240 | "equiv" "==" 241 | "flipBit" "bit-flip" 242 | "gt" ">" 243 | "gte" ">=" 244 | "inc" "inc" 245 | "incP" "inc" 246 | "isNeg" "neg?" 247 | "isPos?" "pos?" 248 | "isZero" "zero?" 249 | "lt" "<" 250 | "lte" "<=" 251 | "max" "max" 252 | "min" "min" 253 | "minus" "-" 254 | "minusP" "-'" 255 | "multiply" "*" 256 | "multiplyP" "*'" 257 | "not" "bit-not" 258 | "or" "bit-or" 259 | "quotient" "quot" 260 | "remainder" "rem" 261 | "setBit" "bit-set" 262 | "shiftLeft" "bit-shift-left" 263 | "shiftRight" "bit-shift-right" 264 | "testBit" "bit-test" 265 | "float_array" "float-array" 266 | "short_array" "short-array" 267 | "int_array" "int-array" 268 | "double_array" "double-array" 269 | "long_array" "long-array" 270 | "char_array" "char-array" 271 | "byte_array" "byte-array" 272 | "boolean_array" "boolean-array" 273 | "booleans" "booleans" 274 | "bytes" "bytes" 275 | "shorts" "shorts" 276 | "ints" "ints" 277 | "chars" "chars" 278 | "longs" "longs" 279 | "doubles" "doubles" 280 | "floats" "floats" 281 | "unchecked_add" "+" 282 | "unchecked_dec" "dec" 283 | "unchecked_inc" "inc" 284 | "unchecked_minus" "-" 285 | "unchecked_multiply" "*" 286 | "unsignedShiftRight" "unsigned-bit-shift-right" 287 | "xor" "bit-xor"}) 288 | 289 | ;; TODO: desugar lists 290 | 291 | (defmethod ast->sugared-ast* :invoke-static [{:keys [^String target method arg-types] :as ast}] 292 | (let [{:keys [args] :as ast} (update ast :args #(mapv ast->sugared-ast* %))] 293 | 294 | (cond 295 | 296 | (and (= target "clojure.lang.RT") 297 | (= method "keyword") 298 | (= 2 (count args)) 299 | (every? (comp #{:const} :op) args)) 300 | 301 | {:op :const 302 | :val (keyword (:val (first args)) (:val (second args)))} 303 | 304 | (and (= target "clojure.lang.RT") 305 | (= method "readString") 306 | (= 1 (count args)) 307 | (string? (-> args first :val)) 308 | ((some-fn integer? decimal?) (try (e/read-string (-> args first :val)) (catch Exception _)))) 309 | 310 | {:op :const 311 | :val (e/read-string (-> args first :val))} 312 | 313 | (and (= target "java.util.regex.Pattern") 314 | (= method "compile") 315 | (= 1 (count args)) 316 | (string? (-> args first :val))) 317 | 318 | {:op :const 319 | :val (-> args first :val re-pattern)} 320 | 321 | ;; WIP: this is too aggressive, might throw away useful casts 322 | (and (= target "clojure.lang.RT") 323 | (#{"doubleCast" "intCast" "box" "charCast" "booleanCast" "byteCast" 324 | "shortCast" "longCast" "floatCast" "uncheckedDoubleCast" 325 | "uncheckedIntCast" "uncheckedCharCast" "uncheckedByteCast" 326 | "uncheckedShortCast" "uncheckedLongCast" "uncheckedFloatCast"} method) 327 | (= 1 (count args))) 328 | (first args) 329 | 330 | (and (= target "clojure.lang.Numbers") 331 | (math-ops method)) 332 | 333 | {:op :invoke 334 | :fn {:op :var 335 | :ns "clojure.core" 336 | :name (math-ops method)} 337 | :args args} 338 | 339 | (and (= target "clojure.lang.Symbol") 340 | (= method "intern") 341 | (= 2 (count args)) 342 | (every? (comp #{:const} :op) args)) 343 | 344 | {:op :const 345 | :val (list 'quote (symbol (:val (first args)) (:val (second args))))} 346 | 347 | (and (= method "valueOf") 348 | (#{"java.lang.Long" "java.lang.Double" "java.lang.Integer" "java.lang.Byte" "java.lang.Short" "java.lang.Float"} target) 349 | (= 1 (count args)) 350 | (-> args (first) :op (= :const)) 351 | (-> args (first) :val number?)) 352 | 353 | {:op :const 354 | :val (-> args (first) :val)} 355 | 356 | (and (= target "clojure.lang.RT") 357 | (= method "var") 358 | (= 2 (count args)) 359 | (every? (comp #{:const} :op) args)) 360 | 361 | ;; too aggressive, on init this should intern 362 | {:op :the-var 363 | :ns (:val (first args)) 364 | :name (:val (second args))} 365 | 366 | ;; best effort for now, should do better to ensure it's a var 367 | (and (= method "invokeStatic") 368 | (.contains target "$")) 369 | 370 | (let [[ns fn-name] ((juxt namespace name) (-> target u/ungensym u/demunge))] 371 | (let [args (if (= "clojure.lang.ISeq" (last arg-types)) 372 | ;; variadic invoke, unroll last arg 373 | (let [[args varargs] ((juxt butlast last) args)] 374 | (into (vec args) (->> varargs :args first :!items deref (mapv ast->sugared-ast*)))) 375 | args)] 376 | {:op :invoke 377 | :fn {:op :var 378 | :ns ns 379 | :name fn-name} 380 | :args args})) 381 | 382 | (and (= target "clojure.lang.Tuple") 383 | (= method "create")) 384 | {:op :vector 385 | :items args} 386 | 387 | (and (= target "clojure.lang.PersistentHashSet") 388 | (= method "create") 389 | (= :array (:op (first args)))) 390 | {:op :set 391 | :items (-> args first :!items deref)} 392 | 393 | (and (= target "clojure.lang.PersistentList") 394 | (= method "create") 395 | (= "java.util.Arrays" (-> args first :target)) 396 | (= "asList" (-> args first :method)) 397 | (= :array (-> args first :args first :op))) 398 | 399 | {:op :list 400 | :items (-> args first :args first :!items deref)} 401 | 402 | (and (= target "clojure.lang.Reflector") 403 | (= method "invokeInstanceMethod")) 404 | 405 | {:op :invoke-instance 406 | :target (first args) 407 | :args (deref (:!items (nth args 2))) 408 | :method (:val (second args))} 409 | 410 | (and (= target "clojure.lang.Reflector") 411 | (= method "invokeNoArgInstanceMember")) 412 | 413 | {:op :invoke-instance 414 | :target (first args) 415 | :args [] 416 | :method (:val (second args))} 417 | 418 | (and (= target "clojure.lang.Reflector") 419 | (= method "invokeStaticMethod") 420 | (= :array (:op (nth args 2))) 421 | (= :invoke-static (:op (first args)))) 422 | 423 | {:op :invoke-static 424 | :target (-> args first :args first :val) 425 | :args (-> args (nth 2) :!items deref) 426 | :method (-> args second :val)} 427 | 428 | (and (= target "clojure.lang.RT") 429 | (#{"vector" "set" "mapUniqueKeys" "map"} method) 430 | (= (-> args first :op) :array)) 431 | 432 | {:op ({"vector" :vector "set" :set "mapUniqueKeys" :map "map" :map} method) 433 | :items (-> args first :!items deref)} 434 | 435 | :else 436 | ast))) 437 | 438 | (defn ast->sugared-ast [x] 439 | (loop [x x] 440 | (let [x' (ast->sugared-ast* x)] 441 | (if (= x x') 442 | x' 443 | (recur x'))))) 444 | -------------------------------------------------------------------------------- /src/clojure/tools/decompiler/utils.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Nicola Mometto & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.tools.decompiler.utils 10 | (:require [clojure.string :as s]) 11 | (:import clojure.lang.Compiler 12 | java.io.Writer)) 13 | 14 | (defn ungensym [s] 15 | (s/replace s #"(__[0-9]+)" "")) 16 | 17 | (defn demunge [s] 18 | (if (#{"_" '_} s) 19 | (symbol s) 20 | (symbol (Compiler/demunge s)))) 21 | 22 | (defn find-methods [methods matches] 23 | (for [method methods 24 | :when (= matches (select-keys method (keys matches)))] 25 | method)) 26 | 27 | (defn find-method [methods matches] 28 | ;; assert just 1 29 | (first (find-methods methods matches))) 30 | 31 | (defn pop-n [stack n] 32 | (let [c (count stack)] 33 | (subvec stack 0 (- c n)))) 34 | 35 | (defn peek-n [stack n] 36 | (let [c (count stack)] 37 | (subvec stack (- c n) c))) 38 | 39 | (defmethod print-method (Class/forName "[Ljava.lang.Object;") [o w] 40 | (.write w "#array") 41 | (.write w " ") 42 | (print-method (vec o) w)) 43 | -------------------------------------------------------------------------------- /src/data_readers.clj: -------------------------------------------------------------------------------- 1 | {array clojure.core/object-array} 2 | --------------------------------------------------------------------------------