aboutsummaryrefslogtreecommitdiff
path: root/src/lang/compiler.clj
diff options
context:
space:
mode:
Diffstat (limited to 'src/lang/compiler.clj')
-rw-r--r--src/lang/compiler.clj254
1 files changed, 155 insertions, 99 deletions
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index c6c75558e..e04178fed 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -1,6 +1,7 @@
(ns lang.compiler
(:refer-clojure :exclude [compile])
(:require [clojure.string :as string]
+ [clojure.set :as set]
[clojure.core.match :refer [match]]
(lang [type :as &type]
[lexer :as &lexer]
@@ -283,108 +284,163 @@
(.visitInsn *writer* Opcodes/POP))
(compile-form (assoc *state* :form (last ?exprs)))))
-(let [oclass (->class "java.lang.Object")
+(let [+tag-sig+ (->type-signature "java.lang.String")
+ variant-class* (->class +variant-class+)
+ oclass (->class "java.lang.Object")
+ +tuple-field-sig+ (->type-signature "java.lang.Object")
equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
+ (defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree]
+ ;; (prn 'compile-decision-tree cleanup-level decision-tree)
+ (match decision-tree
+ [::test-text ?text $body]
+ (let [$else (new Label)]
+ (doto writer
+ ;; object
+ (.visitInsn Opcodes/DUP) ;; object, object
+ (.visitLdcInsn ?text) ;; object, object, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+ (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+ (.visitInsn Opcodes/POP) ;;
+ (.visitJumpInsn Opcodes/GOTO next-label)
+ (.visitLabel $else)
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (inc cleanup-level)])))
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::store [::&analyser/local 0 ?idx] _]
+ ;; object
+ (.visitVarInsn writer Opcodes/ASTORE ?idx) ;;
+
+ [::test-adt ?branches ?cases]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
+ (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
+ (.visitLdcInsn ?tag) ;; variant, tag, tag, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
+ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
+ (.visitInsn Opcodes/POP) ;; variant
+ (do (let [arity (-> ?subcases first (nth 2) count)
+ tuple-class (str "test2/Tuple" arity)]
+ (when (> arity 0)
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" +tuple-field-sig+) ;; variant, object
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class) ;; variant, tuple
+ ))
+ (doseq [subcase ?subcases
+ :let [else-label (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (when (not (empty? ?subseq))
+ (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [next-label (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, tuple, tuple
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?subidx) +tuple-field-sig+) ;; variant, tuple, object
+ (compile-decision-tree mappings cleanup-level next-label else-label ?subpart) ;; variant, tuple
+ (.visitLabel next-label))))
+ (doto writer
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (+ cleanup-level (if (> arity 0) 2 1))]))) ;;
+ (.visitJumpInsn Opcodes/GOTO (or next-label (get mappings $body)))
+ (.visitLabel else-label)))
+ ))
+ ))
+ ;; variant, tag ->
+ (.visitLabel tag-else-label))
+ (->> (doseq [[?tag ?subcases] ?cases
+ :let [tag-else-label (new Label)]])))
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (+ cleanup-level 2)])))
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+ ))
+
+(defn sequence-parts [branches parts]
+ ;; (.print System/out (prn-str 'sequence-parts branches parts))
+ (if (empty? parts)
+ '(())
+ (let [[head & tail] parts
+ expanded (case (:type head)
+ ::&analyser/defaults
+ (for [[?local ?supports] (:stores head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [[::store ?local ?body] #{?body}])
+
+ ::&analyser/text-tests
+ (concat (for [[?text ?supports] (:patterns head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [[::test-text ?text ?body] #{?body}])
+ (for [[_ ?local ?body] (:defaults head)
+ :when (contains? branches ?body)]
+ [[::store ?local ?body] #{?body}]))
+
+ ::&analyser/adt*
+ (do (assert (nil? (:default head)))
+ (list (list [::test-adt branches (into {} (for [[?tag ?struct] (:patterns head)
+ :let [?supports (:branches ?struct)]]
+ [?tag (for [?body (set/intersection branches ?supports)
+ subseq (sequence-parts #{?body} (:parts ?struct))]
+ [::subcase ?body subseq])]))])))
+ )]
+ (for [[step branches*] expanded
+ tail* (sequence-parts branches* tail)
+ ;; :let [_ (.print System/out (prn-str 'tail* tail*))]
+ ]
+ (cons step tail*)))))
+
+(let [oclass (->class "java.lang.Object")
+ equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")
+ ex-class (->class "java.lang.IllegalStateException")]
(defcompiler ^:private compile-case
;; [::&analyser/case ?variant ?branches]
- [::&analyser/case ?base ?variant ?registers ?branches]
- (let [variant-class* (->class +variant-class+)]
- ;; (prn [:case ?base ?variant ?registers ?branches])
- (match (:form ?base)
- [::&analyser/local _ ?base-idx]
- (let [start-label (new Label)
- end-label (new Label)
- default-label (new Label)]
- (dotimes [idx ?registers]
- (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
- (.visitLabel *writer* start-label)
- (compile-form (assoc *state* :form ?variant))
- (.visitTypeInsn *writer* Opcodes/CHECKCAST variant-class*)
- (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
- (doseq [?branch ?branches
- :let [else-label (new Label)]]
- (match ?branch
- [::&analyser/branch-adt ?tag ?members ?body]
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitLdcInsn ?tag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ else-label)
- (do (when (not (empty? ?members))
- (let [tuple-class (str "test2/Tuple" (count ?members))
- mk-sub-fold (fn mk-sub-fold [cleanup-level default-label tuple-class]
- (fn sub-fold [?tfield member]
- (let [next-label (new Label)
- cleanup-label (new Label)]
- (match member
- [::&analyser/local 0 ?idx]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitLabel next-label))
-
- [::&analyser/match-text ?text]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitLdcInsn ?text)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ cleanup-label)
- (.visitJumpInsn Opcodes/GOTO next-label)
- (.visitLabel cleanup-label)
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ cleanup-level])))
- (.visitJumpInsn Opcodes/GOTO default-label)
- (.visitLabel next-label))
-
- [::&analyser/subcase ?subtag ?submembers]
- (let [tuple-class* (str "test2/Tuple" (count ?submembers))]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST variant-class*)
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitLdcInsn ?subtag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ cleanup-label)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class*)
- (do (dorun (map (mk-sub-fold (inc cleanup-level) default-label tuple-class*)
- (range (count ?submembers))
- ?submembers)))
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO next-label)
- (.visitLabel cleanup-label)
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ (inc cleanup-level)])))
- (.visitJumpInsn Opcodes/GOTO default-label)
- (.visitLabel next-label)
- ))))))]
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
- (dorun (map (mk-sub-fold 1 else-label tuple-class)
- (range (count ?members))
- ?members))
- (.visitInsn *writer* Opcodes/POP)))
- (compile-form (assoc *state* :form ?body)))
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))))
- ;; Default branch
- (let [ex-class (->class "java.lang.IllegalStateException")]
- (doto *writer*
- (.visitLabel default-label)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW)))
- (.visitLabel *writer* end-label)))
- )))
+ [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
+ (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
+ ;; (assert false)
+ (let [start-label (new Label)
+ end-label (new Label)
+ ;; default-label (new Label)
+ entries (for [[?branch ?body] ?branch-mappings
+ :let [label (new Label)]]
+ [[?branch label]
+ [label ?body]])
+ mappings* (into {} (map first entries))]
+ (dotimes [idx ?max-registers]
+ (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx))))
+ (compile-form (assoc *state* :form ?variant))
+ (.visitLabel *writer* start-label)
+ (let [default-label (new Label)
+ default-code (:default ?decision-tree)]
+ (compile-decision-tree *writer* mappings* 0 nil default-label
+ (-> (sequence-parts (:branches ?decision-tree) (list ?decision-tree))
+ first first))
+ (.visitLabel *writer* default-label)
+ (if default-code
+ (do (prn 'default-code default-code)
+ (assert false)
+ ;; (.visitInsn Opcodes/POP) ;; ...
+ (compile-form (assoc *state* :form default-code))
+ (.visitJumpInsn *writer* Opcodes/GOTO end-label))
+ (doto *writer*
+ ;; (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))))
+ ;; (compile-decision-tree *state* *writer* mappings* 1 nil (:branches ?decision-tree) ?decision-tree)
+ (doseq [[?label ?body] (map second entries)]
+ (.visitLabel *writer* ?label)
+ (compile-form (assoc *state* :form ?body))
+ (.visitJumpInsn *writer* Opcodes/GOTO end-label))
+ (.visitLabel *writer* end-label)
+ ))
+ ))
(defcompiler ^:private compile-let
[::&analyser/let ?idx ?label ?value ?body]
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 23:55:14 +0000