blob: e57571fefc7a12fdf998529b1e4ece09f711ca74 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
;; Copyright (c) Eduardo Julian. All rights reserved.
;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
;; If a copy of the MPL was not distributed with this file,
;; You can obtain one at http://mozilla.org/MPL/2.0/.
(ns lux.compiler.base
(:require (clojure [template :refer [do-template]]
[string :as string])
[clojure.java.io :as io]
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
(lux [base :as & :refer [|let |do return* return fail fail*]]
[type :as &type]
[host :as &host])
(lux.analyser [base :as &a]
[module :as &a-module])
[lux.host.generics :as &host-generics])
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor)
(java.io File
BufferedOutputStream
FileOutputStream)
(java.lang.reflect Field)))
;; [Constants]
(def !output-dir (atom nil))
(def ^:const ^String function-class "lux/Function")
(def ^:const ^String lux-utils-class "lux/LuxRT")
(def ^:const ^String unit-tag-field "unit_tag")
;; Formats
(def ^:const ^String local-prefix "l")
(def ^:const ^String partial-prefix "p")
(def ^:const ^String closure-prefix "c")
(def ^:const ^String apply-method "apply")
(defn ^String apply-signature [n]
(str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;"))
(def ^:const num-apply-variants 8)
(def ^:const arity-field "_arity_")
(def ^:const partials-field "_partials_")
(def ^:const section-separator (->> 29 char str))
(def ^:const datum-separator (->> 31 char str))
(def ^:const entry-separator (->> 30 char str))
;; [Utils]
(defn ^:private write-file [^String file-name ^bytes data]
(do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name))
(with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))]
(.write stream data))))
(defn ^:private write-output [module name data]
(let [module* (&host/->module-class module)
module-dir (str @!output-dir "/" module*)]
(.mkdirs (File. module-dir))
(write-file (str module-dir "/" name ".class") data)))
(defn class-exists? [^String module ^String class-name]
"(-> Text Text (IO Bool))"
(|do [_ (return nil)
:let [full-path (str @!output-dir "/" module "/" class-name ".class")
exists? (.exists (File. full-path))]]
(return exists?)))
;; [Exports]
(defn ^Class load-class! [^ClassLoader loader name]
;; (prn 'load-class! name)
(.loadClass loader name))
(defn save-class! [name bytecode]
(|do [eval? &/get-eval
module &/get-module-name
loader &/loader
!classes &/classes
:let [real-name (str (&host-generics/->class-name module) "." name)
_ (swap! !classes assoc real-name bytecode)
_ (when (not eval?)
(write-output module name bytecode))
_ (load-class! loader real-name)]]
(return nil)))
(def ^String lux-module-descriptor-name "lux_module_descriptor")
(defn write-module-descriptor! [^String name ^String descriptor]
(|do [_ (return nil)
:let [lmd-dir (str @!output-dir "/" name)
_ (.mkdirs (File. lmd-dir))
_ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]]
(return nil)))
(defn read-module-descriptor! [^String name]
(|do [_ (return nil)]
(return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name)
:encoding "UTF-8"))))
(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>]
(do (defn <wrap-name> [^MethodVisitor writer]
(doto writer
(.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>)))))
(defn <unwrap-name> [^MethodVisitor writer]
(doto writer
(.visitTypeInsn Opcodes/CHECKCAST <class>)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>)))))
wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1
wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1
wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1
wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1
wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2
wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1
wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2
wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1
)
|