From f28db7decf3330379f3f4ab190a9bc01deb50b91 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 2 Jan 2015 01:36:06 -0400 Subject: Pattern matching compiler now generates optimized code. --- src/lang/analyser.clj | 299 +++++++++++++++++++++++++------------------------- src/lang/compiler.clj | 254 +++++++++++++++++++++++++----------------- 2 files changed, 305 insertions(+), 248 deletions(-) (limited to 'src/lang') diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index 72ea43e69..f45f44138 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -117,22 +117,6 @@ =return) ))) -(defn ^:private with-anon-locals [amount k] - (fn [state] - (let [env (-> state :env first) - $scope (:id env) - =locals (for [$local (take amount (iterate inc (:counter env)))] - (annotated [::local $scope $local] [::&type/object "java.lang.Object" []])) - =return ((k =locals) (update-in state [:env] #(cons (update-in (first %) [:counter] + amount) (rest %))))] - (match =return - [::&util/ok [?state ?value]] - (do ;; (prn 'POST-WITH-LOCAL name (-> ?state :env first)) - [::&util/ok [(update-in ?state [:env] #(cons (update-in (first %) [:counter] - amount) (rest %))) - ?value]]) - - _ - =return)))) - (defn ^:private with-locals [mappings monad] (fn [state] (let [=return (monad (update-in state [:env] #(cons (update-in (first %) [:mappings] merge mappings) @@ -423,142 +407,159 @@ (exec [=exprs (map-m analyse-form* ?exprs)] (return (annotated [::do =exprs] (-> =exprs last :type))))) +(let [fold-branches (fn [struct entry] + (let [struct* (clojure.core.match/match (nth entry 0) + [::pm-text ?text] + (clojure.core.match/match (:type struct) + ::text-tests (update-in struct [:patterns ?text] (fn [bodies] + (if bodies + (conj bodies (nth entry 1)) + #{(nth entry 1)}))) + nil (-> struct + (assoc :type ::text-tests) + (assoc-in [:patterns ?text] #{(nth entry 1)})) + _ (assert false "Can't do match.")) + [::pm-variant ?tag ?members] + (clojure.core.match/match (:type struct) + ::adt (update-in struct [:patterns] + (fn [branches] + (if-let [{:keys [arity cases]} (get branches ?tag)] + (if (= arity (count ?members)) + (-> branches + (update-in [?tag :cases] conj {:case ?members + :body (nth entry 1)}) + (update-in [?tag :branches] conj (nth entry 1))) + (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))) + (assoc branches ?tag {:arity (count ?members) + :cases [{:case ?members + :body (nth entry 1)}] + :branches #{(nth entry 1)}})))) + nil (-> struct + (assoc :type ::adt) + (assoc-in [:patterns ?tag] {:arity (count ?members) + :cases [{:case ?members + :body (nth entry 1)}] + :branches #{(nth entry 1)}})) + _ (assert false "Can't do match.")) + + [::pm-local ?local] + (update-in struct [:defaults] conj [::default ?local (nth entry 1)]))] + (update-in struct* [:branches] conj (nth entry 1)))) + base-struct {:type nil + :patterns {} + :defaults [] + :branches #{}} + generate-branches (fn generate-branches [data] + (let [branches* (reduce fold-branches base-struct data)] + ;; (prn 'generate-branches data) + ;; (prn 'branches* branches*) + ;; (.print System/out (prn-str 'branches* branches*)) + ;; (.print System/out (prn-str '(:type branches*) (:type branches*))) + (clojure.core.match/match (:type branches*) + ::text-tests branches* + ::adt (do (assert (<= (count (:defaults branches*)) 1)) + {:type ::adt* + :patterns (into {} (for [[?tag ?struct] (:patterns branches*) + ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)] + ] + [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] + (map #(vector % body) case)))] + (map generate-branches grouped-parts)) + :branches (:branches ?struct)}])) + :default (-> branches* :defaults first) + :branches (:branches branches*)}) + nil {:type ::defaults, + :stores (reduce (fn [total [_ ?store ?body]] + (update-in total [?store] (fn [mapping] + (if mapping + (conj mapping ?body) + #{?body})))) + {} + (:defaults branches*)) + :branches (:branches branches*)}))) + get-vars (fn get-vars [pattern] + (clojure.core.match/match pattern + [::&parser/ident ?name] + (list ?name) + + [::&parser/variant ?tag ?members] + (mapcat get-vars ?members) + + [::&parser/string ?text] + '())) + ->instructions (fn ->instructions [locals pattern] + (clojure.core.match/match pattern + [::&parser/variant ?tag ?members] + [::pm-variant ?tag (map (partial ->instructions locals) ?members)] + + [::&parser/ident ?name] + [::pm-local (get locals ?name)] + + [::&parser/string ?text] + [::pm-text ?text] + ))] + (defn ->decision-tree [$scope $base branches] + (let [;; Step 1: Get all vars + vars+body (for [branch branches] + (clojure.core.match/match branch + [::&parser/case-branch ?pattern ?body] + [(get-vars ?pattern) ?body])) + max-registers (reduce max 0 (map (comp count first) vars+body)) + ;; Step 2: Analyse bodies + [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch] + (clojure.core.match/match branch + [::&parser/case-branch ?pattern ?body] + [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])])) + [0 {} []] + branches) + ;; Step 4: Pattens -> Instructions + branches** (for [[branch branch-vars] (map vector branches* (map first vars+body)) + :let [[_ locals] (reduce (fn [[$local =locals] $var] + [(inc $local) (assoc =locals $var [::local $scope $local])]) + [$base {}] branch-vars)]] + (clojure.core.match/match branch + [::&parser/case-branch ?pattern ?body] + [(->instructions locals ?pattern) ?body])) + ;; _ (prn branches**) + ;; Step 5: Re-structure branching + ] + [max-registers branch-mappings (generate-branches branches**)]))) + (defanalyser analyse-case [::&parser/case ?variant ?branches] - (exec [;; :let [_ (prn '?variant ?variant)] - =variant (analyse-form* ?variant) - ;; :let [_ (prn '=variant =variant)] - ;; {:registers 3, - ;; :patterns {"Cons" {:arity 2, :branches [{:test [:lang/case-try "Cons" [[:lang/case-sub-bind 1] [:lang/case-sub-bind 2]]], :link 1}]}, - ;; "Nil" {:arity 0, :branches [{:test [:lang/case-try "Nil" []], :link 0}]}}, - ;; :paths {:total 2, - ;; :links {1 [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])], - ;; 0 [:lang.parser/ident "ys"]}}} - [$base =branches] (with-anon-locals 1 - (fn [=locals] - ;; (prn 'analyse-case '=locals (map :form =locals)) - (exec [=branches (map-m (fn [?branch] - ;; (prn '?branch ?branch) - (match ?branch - [::&parser/case-branch [::&parser/variant ?tag ?members] ?body] - (let [num-members (count ?members)] - (with-anon-locals num-members - (fn [=locals] - ;; (prn '?branch/=locals (map :form =locals)) - (exec [[inner-num locals+ members+] (reduce-m (fn member-fold [[?inner-num locals-map =members] [?local ?member]] - (match ?member - [::&parser/ident ?name] - (return [?inner-num - (assoc locals-map ?name ?local) - (conj =members (:form ?local))]) - - [::&parser/string ?text] - (return [?inner-num - locals-map - (conj =members [::match-text ?text])]) - - [::&parser/variant ?subtag ?submembers] - (let [num-submembers (count ?submembers)] - (with-anon-locals num-submembers - (fn [=sublocals] - (exec [[subinner-num sublocals+ submembers+] (reduce-m member-fold [0 {} []] (map vector =sublocals ?submembers)) - ;; :let [_ (prn 'subinner-num subinner-num 'sublocals+ sublocals+ 'submembers+ submembers+)] - ] - (return [(+ ?inner-num num-submembers subinner-num) - (merge locals-map sublocals+) - (conj =members [::subcase ?subtag submembers+])]))))) - )) - [0 {} []] - (map vector =locals ?members)) - ;; :let [_ (prn 'inner-num inner-num 'locals+ locals+ 'members+ members+)] - ;; :let [_ (prn (first =members) ?body)] - =body (with-locals locals+ - (analyse-form* ?body)) - ;; :let [_ (prn '?body ?body =body)] - ] - (return [(+ num-members inner-num) [::branch-adt ?tag members+ =body]]))))))) - ?branches)] - (return [(first =locals) =branches])))) - :let [total-registers (+ 1 (reduce max 0 (map first =branches))) - ;; _ (prn '=branches total-registers (map second =branches)) - ;; _ (assert false) - ] - ;; ([::&parser/case-branch [::&parser/variant "Nil" ()] - ;; [::&parser/ident "ys"]] - ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/ident "xs*"])] - ;; [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/fn-call [::&parser/ident "++"] ([::&parser/ident "xs*"] [::&parser/ident "ys"])])]]) - ;; :let [_ (prn '?branches ?branches) - ;; case-analysis (let [gen-impl (fn gen-impl [offset pattern] - ;; (clojure.core.match/match pattern - ;; [::&parser/ident _] - ;; [1 [::case-bind -1 offset]] - - ;; [::&parser/variant ?tag ?members] - ;; (let [regs+insns (mapv (fn [idx member] - ;; (clojure.core.match/match member - ;; [::&parser/ident _] - ;; [1 [::case-sub-bind (+ offset (inc idx))]])) - ;; (range (count ?members)) - ;; ?members)] - ;; [(reduce + 1 (map first regs+insns)) [::case-try ?tag (mapv second regs+insns)]]) - ;; (reduce + (count ?members) (map gen-impl ?members))))] - ;; (reduce (fn [accum branch] - ;; (clojure.core.match/match branch - ;; [::&parser/case-branch ?pattern ?body] - ;; (clojure.core.match/match ?pattern - ;; [::&parser/variant ?tag ?members] - ;; (let [[extra-registers impl] (gen-impl 0 ?pattern) - ;; _ (prn 'impl extra-registers impl) - ;; $branch (get-in accum [:paths :total])] - ;; (-> accum - ;; (update-in [:patterns] - ;; (fn [patterns] - ;; (if (contains? patterns ?tag) - ;; (if (= (get patterns [?tag :arity]) (count ?members)) - ;; (update-in patterns [?tag :branches] conj {:test impl - ;; :link $branch}) - ;; (assert "Pattern arity doesn't match!")) - ;; (assoc patterns ?tag {:arity (count ?members) - ;; :branches [{:test impl - ;; :link $branch}]})))) - ;; (update-in [:paths] - ;; (fn [paths] - ;; (-> paths - ;; (update-in [:total] inc) - ;; (assoc-in [:links $branch] ?body)))) - ;; (update-in [:registers] + (dec extra-registers))))) - ;; )) - ;; {:registers 1 - ;; :patterns {} - ;; :paths {:total 0 - ;; :links {}}} - ;; ?branches)) - ;; _ (prn 'case-analysis case-analysis) - ;; _ (assert false)] - ;; =branches (map-m identity ;; (fn [branch] - ;; ;; ;; (prn 'branch branch) - ;; ;; (match branch - ;; ;; [::&parser/case-branch [::&parser/variant ?tag ?parts] ?body] - ;; ;; (exec [;; :let [_ (prn ?tag ?label '?body ?body)] - ;; ;; ;; (reduce-m (fn [?part] - ;; ;; ;; (match ?part - ;; ;; ;; [::&parser/ident ?label] - ;; ;; ;; (exec [idx next-local-idx - ;; ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []] - ;; ;; ;; (analyse-form* ?body))] - ;; ;; ;; (return ...))) - ;; ;; ;; ) - ;; ;; ;; ?parts) - ;; ;; idx next-local-idx - ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []] - ;; ;; (analyse-form* ?body)) - ;; ;; ;; :let [_ (prn ?tag ?label '=body =body)] - ;; ;; ] - ;; ;; (return [?tag ?label idx =body])))) - ;; ?branches) - ;; :let [_ (prn '=branches =branches)] + (exec [=variant (analyse-form* ?variant) + ;; :let [_ (prn 'analyse-case '=variant =variant)] + $scope scope-id + ;; :let [_ (prn 'analyse-case '$scope $scope)] + $base next-local-idx + ;; :let [_ (prn 'analyse-case '$base $base)] + [registers mappings tree] (exec [=branches (map-m (fn [?branch] + (match ?branch + [::&parser/case-branch [::&parser/variant ?tag ?members] ?body] + (exec [[_ locals+] (reduce-m (fn member-fold [[$local locals-map] ?member] + (match ?member + [::&parser/ident ?name] + (return [(inc $local) (assoc locals-map ?name (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))]) + + [::&parser/variant ?subtag ?submembers] + (reduce-m member-fold [$local locals-map] ?submembers) + + _ + (return [$local locals-map]) + )) + [$base {}] + ?members) + ;; :let [_ (prn 'analyse-case 'locals+ locals+)] + =body (with-locals locals+ + (analyse-form* ?body)) + ;; :let [_ (prn 'analyse-case '=body =body)] + ] + (return [::&parser/case-branch [::&parser/variant ?tag ?members] =body])))) + ?branches)] + (return (->decision-tree $scope $base =branches))) + ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])] ] - (return (annotated [::case $base =variant total-registers (map second =branches)] ::&type/nothing)))) + (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing)))) (defanalyser analyse-let [::&parser/let ?label ?value ?body] 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 "" "()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 "" "()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] -- cgit v1.2.3