aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/base.clj5
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/base.clj1
-rw-r--r--src/lux/compiler/host.clj43
-rw-r--r--src/lux/compiler/lambda.clj115
-rw-r--r--src/lux/compiler/lux.clj2
-rw-r--r--src/lux/optimizer.clj12
7 files changed, 70 insertions, 112 deletions
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 02bd55112..d514e17e5 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -504,6 +504,11 @@
(defn |length [xs]
(fold (fn [acc _] (inc acc)) 0 xs))
+(defn |range* [from to]
+ (if (<= from to)
+ ($Cons from (|range* (inc from) to))
+ $Nil))
+
(let [|range* (fn |range* [from to]
(if (< from to)
($Cons from (|range* (inc from) to))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 89a608ad0..fe256a942 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -85,8 +85,8 @@
(&o/$case ?value ?match)
(&&case/compile-case compile-expression ?value ?match)
- (&o/$function ?level ?scope ?env ?body)
- (&&lambda/compile-function compile-expression ?level ?scope ?env ?body)
+ (&o/$function ?arity ?scope ?env ?body)
+ (&&lambda/compile-function compile-expression ?arity ?scope ?env ?body)
;; Must get rid of this one...
(&o/$ann ?value-ex ?type-ex ?value-type)
diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj
index 19d918ef9..1c5301a68 100644
--- a/src/lux/compiler/base.clj
+++ b/src/lux/compiler/base.clj
@@ -38,6 +38,7 @@
(def ^String apply-method "apply")
(defn ^String apply-signature [n]
(str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;"))
+(def num-apply-variants 8)
(def exported-separator " ")
(def def-separator "\t")
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 54def6b76..0726e1ecf 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -536,45 +536,22 @@
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))
- =apply1 (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature 1) nil nil)
+ _ (dotimes [arity* &&/num-apply-variants]
+ (let [arity (inc arity*)]
+ (if (= 1 arity)
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil)
(.visitEnd))
- =apply2 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 2) nil nil)
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil)
(.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- =apply3 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 3) nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 2))
+ (-> (.visitVarInsn Opcodes/ALOAD idx)
+ (->> (dotimes [idx arity])))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity)))
(.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitVarInsn Opcodes/ALOAD 3)
+ (.visitVarInsn Opcodes/ALOAD arity)
(.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
- (.visitEnd))
- =apply4 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 4) nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitVarInsn Opcodes/ALOAD 3)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 3))
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitVarInsn Opcodes/ALOAD 4)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- ]]
+ (.visitEnd)))))]]
(&&/save-class! (second (string/split &&/function-class #"/"))
(.toByteArray (doto =class .visitEnd)))))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 3f3e1e5c7..7ef4e439d 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -64,44 +64,27 @@
(->> (dotimes [idx amount])))))
(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount]
- (case amount
- 1 (doto method-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start 1)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))
- 2 (doto method-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start 2)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 2)))
- 3 (doto method-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start 3)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 3)))
- 4 (doto method-writer
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start 4)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 4)))
- ;; > 4
+ (let [max-args-num (min amount &&/num-apply-variants)]
(doto method-writer
(.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (consecutive-args start 4)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 4))
- (consecutive-applys (+ start 4) (- amount 4)))
- ))
+ (consecutive-args start max-args-num)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num))
+ (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants))
+ (->> (when (> amount &&/num-apply-variants)))))))
-(defn ^:private lambda-impl-signature [level]
- (str "(" (&/fold str "" (&/|repeat level field-sig)) ")" lambda-return-sig))
+(defn ^:private lambda-impl-signature [arity]
+ (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig))
-(defn ^:private lambda-<init>-signature [env level]
- (if (> level 1)
- (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec level) field-sig)) ")"
+(defn ^:private lambda-<init>-signature [env arity]
+ (if (> arity 1)
+ (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")"
<init>-return)
(str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")"
<init>-return)))
-(defn ^:private add-lambda-<init> [class class-name level env]
+(defn ^:private add-lambda-<init> [class class-name arity env]
(let [closure-length (&/|length env)]
- (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env level) nil nil)
+ (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env arity) nil nil)
(.visitCode)
;; Do normal object initialization
(.visitVarInsn Opcodes/ALOAD 0)
@@ -114,16 +97,16 @@
;; Add all the partial arguments
(-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn % Opcodes/ALOAD partial-register))
(->> (|let [partial-register (+ (inc idx*) (inc closure-length))])
- (dotimes [idx* (dec level)]))))
- (->> (when (> level 1))))
+ (dotimes [idx* (dec arity)]))))
+ (->> (when (> arity 1))))
;; Finish
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd))))
(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
- (defn ^:private add-lambda-impl [class class-name compile level impl-body]
- (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature level) nil nil)
+ (defn ^:private add-lambda-impl [class class-name compile arity impl-body]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil)
(.visitCode))
(|do [^MethodVisitor *writer* &/get-writer
ret (compile impl-body)
@@ -133,7 +116,7 @@
(.visitEnd))]]
(return ret)))))
-(defn ^:private instance-closure [compile lambda-class level closed-over]
+(defn ^:private instance-closure [compile lambda-class arity closed-over]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
@@ -143,15 +126,15 @@
[?name [_ (&a/$captured _ _ ?source)]]
(compile ?source)))
closed-over)
- :let [_ (when (> level 1)
+ :let [_ (when (> arity 1)
(doto *writer*
(.visitLdcInsn (int 0))
- (fill-nulls! (dec level))))]
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" (lambda-<init>-signature closed-over level))]]
+ (fill-nulls! (dec arity))))]
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" (lambda-<init>-signature closed-over arity))]]
(return nil)))
-(defn ^:private add-lambda-reset [class-writer class-name level env]
- (if (> level 1)
+(defn ^:private add-lambda-reset [class-writer class-name arity env]
+ (if (> arity 1)
(doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil)
(.visitCode)
(.visitTypeInsn Opcodes/NEW class-name)
@@ -159,8 +142,8 @@
(-> (get-field! class-name (str &&/closure-prefix cidx))
(->> (dotimes [cidx (&/|length env)])))
(.visitLdcInsn (int 0))
- (fill-nulls! (dec level))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env level))
+ (fill-nulls! (dec arity))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity))
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
@@ -171,9 +154,9 @@
(.visitMaxs 0 0)
(.visitEnd))))
-(defn ^:private add-lambda-apply-n [class-writer +degree+ class-name level env compile impl-body]
- (if (> level 1)
- (let [num-partials (dec level)
+(defn ^:private add-lambda-apply-n [class-writer +degree+ class-name arity env compile impl-body]
+ (if (> arity 1)
+ (let [num-partials (dec arity)
$default (new Label)
$labels* (map (fn [_] (new Label)) (repeat num-partials nil))
$labels (vec (concat $labels* (list $default)))
@@ -188,7 +171,7 @@
(int (alength frame-locals)) frame-locals
(int (alength frame-stack)) frame-stack)
(.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*))
- ;; (< stage (- level +degree+))
+ ;; (< stage (- arity +degree+))
(-> (doto (.visitLabel $label)
(.visitFrame Opcodes/F_NEW
(int (alength frame-locals)) frame-locals
@@ -203,9 +186,9 @@
(->> (dotimes [idx stage])))
(consecutive-args 1 +degree+)
(fill-nulls! (- (- num-partials +degree+) stage))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env level))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env arity))
(.visitJumpInsn Opcodes/GOTO $end))
- (->> (cond (= stage (- level +degree+))
+ (->> (cond (= stage (- arity +degree+))
(doto method-writer
(.visitLabel $label)
(.visitFrame Opcodes/F_NEW
@@ -217,12 +200,12 @@
(-> (get-field! class-name (str &&/partial-prefix idx))
(->> (dotimes [idx stage])))
(consecutive-args 1 +degree+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
(.visitJumpInsn Opcodes/GOTO $end))
- (> stage (- level +degree+))
+ (> stage (- arity +degree+))
(let [base 1
- args-to-completion (- level stage)
+ args-to-completion (- arity stage)
args-left (- +degree+ args-to-completion)]
(doto method-writer
(.visitLabel $label)
@@ -234,12 +217,12 @@
(-> (get-field! class-name (str &&/partial-prefix idx))
(->> (dotimes [idx stage])))
(consecutive-args base args-to-completion)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity))
(consecutive-applys (+ base args-to-completion) args-left)
(.visitJumpInsn Opcodes/GOTO $end)))
:else)
- (doseq [[stage $label] (map vector (range level) $labels)])))
+ (doseq [[stage $label] (map vector (range arity) $labels)])))
(.visitLabel $end)
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
@@ -259,7 +242,7 @@
;; [Exports]
(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
- (defn compile-function [compile level ?scope ?env ?body]
+ (defn compile-function [compile arity ?scope ?env ?body]
(|do [[file-name _ _] &/cursor
:let [name (&host/location (&/|tail ?scope))
class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
@@ -276,25 +259,17 @@
(doto (.visitEnd)))
(-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil)
(doto (.visitEnd))
- (->> (dotimes [idx (dec level)]))))
- (->> (when (> level 1))))
+ (->> (dotimes [idx (dec arity)]))))
+ (->> (when (> arity 1))))
(.visitSource file-name nil)
- (add-lambda-<init> class-name level ?env)
- (add-lambda-reset class-name level ?env)
+ (add-lambda-<init> class-name arity ?env)
+ (add-lambda-reset class-name arity ?env)
)]
- _ (if (> level 1)
- (add-lambda-impl =class class-name compile level ?body)
- (return nil))
- _ (add-lambda-apply-n =class 1 class-name level ?env compile ?body)
- _ (if (>= level 2)
- (add-lambda-apply-n =class 2 class-name level ?env compile ?body)
- (return nil))
- _ (if (>= level 3)
- (add-lambda-apply-n =class 3 class-name level ?env compile ?body)
- (return nil))
- _ (if (>= level 4)
- (add-lambda-apply-n =class 4 class-name level ?env compile ?body)
+ _ (if (> arity 1)
+ (add-lambda-impl =class class-name compile arity ?body)
(return nil))
+ _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body)
+ (&/|range* 1 (min arity &&/num-apply-variants)))
:let [_ (.visitEnd =class)]
_ (&&/save-class! name (.toByteArray =class))]
- (instance-closure compile class-name level ?env))))
+ (instance-closure compile class-name arity ?env))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index e1af775f7..0facb74c1 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -116,7 +116,7 @@
_ (&/map% compile ?args)
:let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]]
(return nil)))
- (&/|partition 4 ?args))]
+ (&/|partition &&/num-apply-variants ?args))]
(return nil)))
(defn ^:private compile-def-type [compile ?body]
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 4b617b591..09f23886e 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -77,8 +77,8 @@
(&/T [_pattern (de-meta _body)])))
branches))
- [meta ($function level scope captured body*)]
- ($function level
+ [meta ($function arity scope captured body*)]
+ ($function arity
scope
(&/|map (fn [capture]
(|let [[_name _captured] capture]
@@ -126,8 +126,8 @@
(shift-function-body own-body? _body)])))
branches))])
- [meta ($function level scope captured body*)]
- (&/T [meta ($function level
+ [meta ($function arity scope captured body*)]
+ (&/T [meta ($function arity
(de-scope scope)
(&/|map (fn [capture]
(|let [[_name [_meta ($captured _scope _idx _source)]] capture]
@@ -215,8 +215,8 @@
[meta (&-base/$lambda scope captured body)]
(|case (optimize body)
- [_ ($function _level _scope _captured _body)]
- (&/T [meta ($function (inc _level) scope (optimize-closure optimize captured) (shift-function-body true _body))])
+ [_ ($function _arity _scope _captured _body)]
+ (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))])
=body
(&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)]))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 16:08:02 +0000