diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 281 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 93 |
2 files changed, 250 insertions, 124 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index eb6ca7fdd..6b823b3ee 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -476,18 +476,38 @@ (defn ->token [x] ;; (prn '->token x) (match x - [::&parser/tag ?tag] + [::&parser/bool ?bool] (doto (.newInstance (.loadClass loader "test2.Variant1")) - (-> .-tag (set! "Tag")) - (-> .-_1 (set! ?tag))) + (-> .-tag (set! "Bool")) + (-> .-_1 (set! ?bool))) + [::&parser/int ?int] + (doto (.newInstance (.loadClass loader "test2.Variant1")) + (-> .-tag (set! "Int")) + (-> .-_1 (set! ?int))) + [::&parser/real ?real] + (doto (.newInstance (.loadClass loader "test2.Variant1")) + (-> .-tag (set! "Real")) + (-> .-_1 (set! ?real))) + [::&parser/char ?elem] + (doto (.newInstance (.loadClass loader "test2.Variant1")) + (-> .-tag (set! "Char")) + (-> .-_1 (set! ?elem))) [::&parser/text ?text] (doto (.newInstance (.loadClass loader "test2.Variant1")) (-> .-tag (set! "Text")) (-> .-_1 (set! ?text))) + [::&parser/tag ?tag] + (doto (.newInstance (.loadClass loader "test2.Variant1")) + (-> .-tag (set! "Tag")) + (-> .-_1 (set! ?tag))) [::&parser/ident ?ident] (doto (.newInstance (.loadClass loader "test2.Variant1")) (-> .-tag (set! "Ident")) (-> .-_1 (set! ?ident))) + [::&parser/tuple ?elems] + (doto (.newInstance (.loadClass loader "test2.Variant1")) + (-> .-tag (set! "Tuple")) + (-> .-_1 (set! (->tokens ?elems)))) [::&parser/form ?elems] (doto (.newInstance (.loadClass loader "test2.Variant1")) (-> .-tag (set! "Form")) @@ -508,9 +528,14 @@ (defn ->clojure-token [x] ;; (prn '->clojure-token x (.-tag x)) (case (.-tag x) + "Bool" [::&parser/bool (-> x .-_1)] + "Int" [::&parser/int (-> x .-_1)] + "Real" [::&parser/real (-> x .-_1)] + "Char" [::&parser/char (-> x .-_1)] "Text" [::&parser/text (-> x .-_1)] - "Ident" [::&parser/ident (-> x .-_1)] "Tag" [::&parser/tag (-> x .-_1)] + "Ident" [::&parser/ident (-> x .-_1)] + "Tuple" [::&parser/tuple (-> x .-_1 tokens->clojure)] "Form" [::&parser/form (-> x .-_1 tokens->clojure)])) (defn tokens->clojure [xs] @@ -576,56 +601,87 @@ (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)))) +(let [fold-branch (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-local ?local] + (update-in struct [:defaults] conj [::default ?local (nth entry 1)]) + + [::pm-tuple ?members] + (clojure.core.match/match (:type struct) + ::tuple (update-in struct [:patterns] + (fn [{:keys [arity cases] :as branch}] + (if (= arity (count ?members)) + (-> branch + (update-in [:cases] conj {:case ?members + :body (nth entry 1)}) + (update-in [:branches] conj (nth entry 1))) + (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))))) + nil (-> struct + (assoc :type ::tuple) + (assoc :patterns {:arity (count ?members) + :cases [{:case ?members + :body (nth entry 1)}] + :branches #{(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.")) + )] + (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)] + (let [branches* (reduce fold-branch 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* + ::tuple (do (assert (<= (count (:defaults branches*)) 1)) + {:type ::tuple* + :patterns (into {} (for [[?tag ?struct] {nil (: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*)}) ::adt (do (assert (<= (count (:defaults branches*)) 1)) {:type ::adt* :patterns (into {} (for [[?tag ?struct] (:patterns branches*) @@ -648,36 +704,43 @@ :branches (:branches branches*)}))) get-vars (fn get-vars [pattern] (clojure.core.match/match pattern - [::&parser/ident ?name] - (list ?name) + [::&parser/text ?text] + '() [::&parser/tag _] '() - [::&parser/form ([[::&parser/tag _] & ?members] :seq)] + [::&parser/ident ?name] + (list ?name) + + [::&parser/tuple ?members] (mapcat get-vars ?members) [::&parser/variant ?tag ?members] (mapcat get-vars ?members) - - [::&parser/text ?text] - '())) + + [::&parser/form ([[::&parser/tag _] & ?members] :seq)] + (mapcat get-vars ?members) + )) ->instructions (fn ->instructions [locals pattern] (clojure.core.match/match pattern + [::&parser/text ?text] + [::pm-text ?text] + [::&parser/tag ?tag] [::pm-variant ?tag '()] - [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] - [::pm-variant ?tag (map (partial ->instructions locals) ?members)] + [::&parser/ident ?name] + [::pm-local (get locals ?name)] + + [::&parser/tuple ?members] + [::pm-tuple (map (partial ->instructions locals) ?members)] [::&parser/variant ?tag ?members] [::pm-variant ?tag (map (partial ->instructions locals) ?members)] - - [::&parser/ident ?name] - [::pm-local (get locals ?name)] - - [::&parser/text ?text] - [::pm-text ?text] + + [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] + [::pm-variant ?tag (map (partial ->instructions locals) ?members)] ))] (defn ->decision-tree [$scope $base branches] (let [;; Step 1: Get all vars @@ -706,52 +769,64 @@ ] [max-registers branch-mappings (generate-branches branches**)]))) -(defanalyser analyse-case - [::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)] - (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 [[?pattern ?body]] - ;; (prn '?branch ?branch) - (match ?pattern - [::&parser/ident ?name] - (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])} - (analyse-form* ?body))] - (return [::case-branch [::&parser/ident ?name] =body])) - - [::&parser/tag ?tag] - (exec [=body (analyse-form* ?body)] - (return [::case-branch [::&parser/variant ?tag '()] =body])) - - [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] - (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/form ([[::&parser/tag ?subtag] & ?submembers] :seq)] - (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 [::case-branch [::&parser/variant ?tag ?members] =body])) - )) - (partition 2 ?branches))] - (return (->decision-tree $scope $base =branches))) - ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])] - ] - (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing)))) +(let [locals-getter (fn [$scope] + (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/tuple ?submembers] + (reduce-m member-fold [$local locals-map] ?submembers) + + [::&parser/form ([[::&parser/tag ?subtag] & ?submembers] :seq)] + (reduce-m member-fold [$local locals-map] ?submembers) + + _ + (return [$local locals-map]) + )))] + (defanalyser analyse-case + [::&parser/form ([[::&parser/ident "case"] ?variant & ?branches] :seq)] + (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 [[?pattern ?body]] + ;; (prn '?branch ?branch) + (match ?pattern + [::&parser/ident ?name] + (exec [=body (with-locals {?name (annotated [::local $scope $base] [::&type/object "java.lang.Object" []])} + (analyse-form* ?body))] + (return [::case-branch [::&parser/ident ?name] =body])) + + [::&parser/tag ?tag] + (exec [=body (analyse-form* ?body)] + (return [::case-branch [::&parser/variant ?tag '()] =body])) + + [::&parser/tuple ?members] + (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base {}] ?members) + ;; :let [_ (prn 'analyse-case 'locals+ locals+)] + =body (with-locals locals+ + (analyse-form* ?body)) + ;; :let [_ (prn 'analyse-case '=body =body)] + ] + (return [::case-branch [::&parser/tuple ?members] =body])) + + [::&parser/form ([[::&parser/tag ?tag] & ?members] :seq)] + (exec [[_ locals+] (reduce-m (locals-getter $scope) [$base {}] ?members) + ;; :let [_ (prn 'analyse-case 'locals+ locals+)] + =body (with-locals locals+ + (analyse-form* ?body)) + ;; :let [_ (prn 'analyse-case '=body =body)] + ] + (return [::case-branch [::&parser/variant ?tag ?members] =body])) + )) + (partition 2 ?branches))] + (return (->decision-tree $scope $base =branches))) + ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])] + ] + (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))) (defanalyser analyse-let [::&parser/form ([[::&parser/ident "let"] [::&parser/ident ?label] ?value ?body] :seq)] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index a98687971..aea9ea1e2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -42,6 +42,7 @@ )) (def ^:private +variant-class+ "test2.Variant") +(def ^:private +tuple-class+ "test2.Tuple") (defmacro ^:private defcompiler [name match body] `(defn ~name [~'*state*] @@ -308,6 +309,7 @@ (let [+tag-sig+ (->type-signature "java.lang.String") variant-class* (->class +variant-class+) + tuple-class* (->class +tuple-class+) oclass (->class "java.lang.Object") +variant-field-sig+ (->type-signature "java.lang.Object") equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] @@ -333,6 +335,32 @@ (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO (get mappings $body))) + [::test-tuple ?branches ?cases] + (let [[_ ?subcases] (first ?cases) + arity (-> ?subcases first (nth 2) count) + tuple-class** (str tuple-class* arity)] + (doto writer + ;; object + (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple + (do (doseq [subcase ?subcases + :let [next-subcase (new Label)]] + (match subcase + [::subcase $body ?subseq] + (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) + :let [sub-next-elem (new Label)]] + (doto writer + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str "_" (inc ?subidx)) +variant-field-sig+) ;; tuple, object + (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple + (.visitLabel sub-next-elem))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel next-subcase))) + ))) + (.visitInsn Opcodes/POP) ;; -> + (.visitJumpInsn Opcodes/GOTO default-label))) + [::test-adt ?branches ?cases] (doto writer ;; object @@ -402,6 +430,29 @@ :when (contains? branches ?body)] [[::store ?local ?body] #{?body}])) + ::&analyser/tuple* + (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) + ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] + :let [?parts (:parts ?struct) + num-parts (count ?parts) + ?supports (:branches ?struct) + subcases (for [?body (set/intersection branches ?supports) + subseq (sequence-parts #{?body} ?parts) + ;; :let [_ (when (= "Symbol" ?tag) + ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] + :when (= num-parts (count subseq))] + [::subcase ?body subseq])] + :when (not (empty? subcases))] + [?tag subcases]))] + (if (empty? patterns) + '() + (list [[::test-tuple branches patterns] + branches]))) + (if-let [[_ ?local ?body] (:default head)] + (for [?body (set/intersection branches #{?body})] + [[::default ?local ?body] #{?body}]) + '())) + ::&analyser/adt* (do ;; (prn '(:default head) (:default head)) ;; (assert (nil? (:default head))) @@ -422,27 +473,27 @@ ;; '() ;; (list [[::test-adt branches patterns] ;; branches]))) - (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) - ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] - :let [?parts (:parts ?struct) - num-parts (count ?parts) - ?supports (:branches ?struct) - subcases (for [?body (set/intersection branches ?supports) - subseq (sequence-parts #{?body} ?parts) - ;; :let [_ (when (= "Symbol" ?tag) - ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] - :when (= num-parts (count subseq))] - [::subcase ?body subseq])] - :when (not (empty? subcases))] - [?tag subcases]))] - (if (empty? patterns) - '() - (list [[::test-adt branches patterns] - branches]))) - (if-let [[_ ?local ?body] (:default head)] - (for [?body (set/intersection branches #{?body})] - [[::default ?local ?body] #{?body}]) - '())) + (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head) + ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))] + :let [?parts (:parts ?struct) + num-parts (count ?parts) + ?supports (:branches ?struct) + subcases (for [?body (set/intersection branches ?supports) + subseq (sequence-parts #{?body} ?parts) + ;; :let [_ (when (= "Symbol" ?tag) + ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))] + :when (= num-parts (count subseq))] + [::subcase ?body subseq])] + :when (not (empty? subcases))] + [?tag subcases]))] + (if (empty? patterns) + '() + (list [[::test-adt branches patterns] + branches]))) + (if-let [[_ ?local ?body] (:default head)] + (for [?body (set/intersection branches #{?body})] + [[::default ?local ?body] #{?body}]) + '())) ) )] (for [[step branches*] expanded |