blob: cb8ad0037fe61335c4b2a91a715ae9da504e8f86 (
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
|
;; 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.lambda
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
clojure.core.match
clojure.core.match.array
(lux [base :as & :refer [|do return* return fail fail* |case]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
[host :as &host])
[lux.analyser.base :as &a]
(lux.compiler [base :as &&]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
MethodVisitor)))
;; [Utils]
(def ^:private clo-field-sig (&host/->type-signature "java.lang.Object"))
(def ^:private lambda-return-sig (&host/->type-signature "java.lang.Object"))
(def ^:private <init>-return "V")
(def ^:private lambda-impl-signature
(str "(" clo-field-sig ")" lambda-return-sig))
(defn ^:private lambda-<init>-signature [env]
(str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
<init>-return))
(defn ^:private add-lambda-<init> [class class-name env]
(doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env) nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
(-> (doto (.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
(.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(|case ?name+?captured
[?name [_ (&a/$captured _ ?captured-id ?source)]])
(doseq [?name+?captured (&/->seq env)])))
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd)))
(defn ^:private add-lambda-apply [class class-name env]
(doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil)
(.visitCode)
(.visitVarInsn Opcodes/ALOAD 0)
(.visitVarInsn Opcodes/ALOAD 1)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" lambda-impl-signature)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
(&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil)
(.visitCode))
(|do [^MethodVisitor *writer* &/get-writer
:let [$start (new Label)
$end (new Label)]
ret (compile impl-body)
:let [_ (doto *writer*
(.visitLabel $end)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))]]
(return ret)))))
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
(.visitInsn Opcodes/DUP))]
_ (&/map% (fn [?name+?captured]
(|case ?name+?captured
[?name [_ (&a/$captured _ _ ?source)]]
(compile ?source)))
closed-over)
:let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]]
(return nil)))
;; [Exports]
(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
(defn compile-lambda [compile ?scope ?env ?body]
(|do [[file-name _ _] &/cursor
:let [name (&host/location (&/|tail ?scope))
class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 lambda-flags
class-name nil "java/lang/Object" (into-array [&&/function-class]))
(-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil)
(.visitEnd))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(|case ?name+?captured
[?name [_ (&a/$captured _ ?captured-id ?source)]])
(doseq [?name+?captured (&/->seq ?env)])))
(.visitSource file-name nil)
(add-lambda-apply class-name ?env)
(add-lambda-<init> class-name ?env)
)]
_ (add-lambda-impl =class compile lambda-impl-signature ?body)
:let [_ (.visitEnd =class)]
_ (&&/save-class! name (.toByteArray =class))]
(instance-closure compile class-name ?env (lambda-<init>-signature ?env)))))
|
