diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lang.clj | 411 | ||||
| -rw-r--r-- | src/lang/analyser.clj | 299 | ||||
| -rw-r--r-- | src/lang/compiler.clj | 254 |
3 files changed, 458 insertions, 506 deletions
diff --git a/src/lang.clj b/src/lang.clj index 4dd8e159c..5e4316db4 100644 --- a/src/lang.clj +++ b/src/lang.clj @@ -6,11 +6,6 @@ [compiler :as &compiler]) :reload)) -(defn write-file [file data] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] - ;; (prn 'write-file 'file file 'stream stream 'data data) - (.write stream data))) - (comment ;; TODO: Add macros. ;; TODO: Re-implement compiler in language. @@ -32,28 +27,6 @@ ;; TODO: ;; TODO: - (let [test '([:lang.parser/case-branch [:lang.parser/variant "Nil" ()] - [:lang.parser/ident "yx"]] - [:lang.parser/case-branch [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/ident "xs*"])] - [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])]]) - convert (fn [cases] - (list (reduce (fn [acc [_ shape body]] - (clojure.core.match/match shape - [::&parser/variant ?tag ?elems] - (let [=elems (map (fn [elem] - (clojure.core.match/match elem - [::&parser/ident ?ident] - [::ident ?ident])) - ?elems)] - (conj acc [?tag =elems body])))) - [] - cases)))] - (convert test)) - - (enumerate (list (list '["Nil" [] branch-0] - '["Cons" [x xs*] branch-1]))) - - (let [source-code (slurp "test2.lang") tokens (&lexer/lex source-code) ;; _ (prn 'tokens tokens) @@ -64,249 +37,171 @@ class-data (&compiler/compile "test2" ann-syntax) ;; _ (prn 'class-data class-data) ] - (write-file "test2.class" class-data)) + (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))] + (.write stream class-data))) ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 ) (comment - - (let [data '([::&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"])])]]) - ;; count-registers (fn count-registers [pattern] - ;; (clojure.core.match/match pattern - ;; [::&parser/ident _] - ;; 0 - - ;; [::&parser/variant _ ?members] - ;; (reduce + (count ?members) (map count-registers ?members)))) - gen-impl (fn gen-impl [offset pattern] - (clojure.core.match/match pattern - [::&parser/ident _] - [1 [::case-bind -1 offset]] + ;; (let [branches '([::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~"])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]] + ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~@"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "++"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])])]] + ;; [::&parser/case-branch [::&parser/ident "_"] [::&parser/variant "Cons" ([::&parser/ident "head"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]]) + ;; ;; Step 1: Get all vars + ;; get-vars (fn get-vars [pattern] + ;; (clojure.core.match/match pattern + ;; [::&parser/ident ?name] + ;; (list ?name) - [::&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 {}}} - data)) + ;; [::&parser/variant ?tag ?members] + ;; (mapcat get-vars ?members) + + ;; [::&parser/string ?text] + ;; '())) + ;; vars+body (for [branch branches] + ;; (clojure.core.match/match branch + ;; [::&parser/case-branch ?pattern ?body] + ;; [(get-vars ?pattern) ?body])) + ;; ;; _ (prn 'vars+body vars+body) + ;; max-registers (reduce max 0 (map (comp count first) vars+body)) + ;; ;; _ (prn 'max-registers max-registers) + ;; ;; Step 2: Analyse bodies + ;; ;; all-analysis (map (fn [[vars body]] + ;; ;; (reduce #(with-local %2 [::&type/object "java.lang.Object" []] %1) + ;; ;; (analyse-form* body) + ;; ;; (reverse vars))) + ;; ;; vars+body) + ;; ;; Step 3: Extract 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 + ;; ;; ->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] + ;; ;; )) + ;; ;; $scope 0 ;; scope-id + ;; ;; $local 11 ;; next-local-idx + ;; ;; 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])]) + ;; ;; [$local {}] branch-vars)]] + ;; ;; (clojure.core.match/match branch + ;; ;; [::&parser/case-branch ?pattern ?body] + ;; ;; [(->instructions locals ?pattern) ?body])) + ;; ;; _ (prn branches**) + ;; ;; Step 5: Re-structure branching + ;; ] + ;; ;; [branch-mappings branches**] + ;; branches*) - '([::&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"])])]]) - - '([:try "Nil" []] - [:try "Cons" [[:bind 0 1] [:bind 1 2]]]) - (list '["Nil" [] branch-0] - '["Cons" [x xs*] branch-1]) - - [:if [% tag "Nil"] - branch-0 - [:let [%0 %1] - branch-1]] - (let [enumerate (fn [xs] (map vector (range (count xs)) xs)) - cases (enumerate (list (list '["Nil" [] branch-0] - '["Cons" [x xs*] branch-1]))) - classify-cases (fn [[idx cases]] - [idx (reduce (fn [order [tag members branch]] - (if-let [{:keys [arity branches] :as sub-struct} (get order tag)] - (if (= arity (count members)) - (update-in order [tag :branches] conj [members branch]) - (assert (str "Arity doesn't match:" (count members) " != " arity))) - (assoc order tag {:arity (count members) - :branches (vector [members branch])}))) - {} - cases)]) - ;; case->struct (fn [cases] - ;; (let [struct (classify-case cases) - ;; struct* (seq struct)] - ;; (reduce (fn [inner [tag {:keys [arity branches]}]] - ;; [:if [% tag "Nil"] - ;; branch-0 - ;; inner]) - ;; (second (last struct*)) - ;; (butlast struct*)) - ;; )) - ] - ;; (classify-case cases) - (let [;; separated (apply map list cases) - classifications (map classify-cases cases) - classifications* (sort-by first > classifications)] - ((fn [[idx struct]] - (prn idx struct) - (if-let [default (get struct nil)] - (reduce (fn [[dbinds dbranch] [tag [binds branch]]] - [:if tag - [:let binds - branch] - [:let dbinds - dbranch]]) - (-> default :branches first) - (seq struct)) - (let [struct* (seq struct)] - (reduce (fn [[dbinds dbranch] [tag sub-struct]] - (let [[binds branch] (-> sub-struct :branches first)] - [:if tag - [:let binds - branch] - [:let dbinds - dbranch]])) - (-> struct* last second :branches first) - (butlast struct*))))) - (first classifications*)) - )) - ;; ([0 {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]}, "Nil" {:arity 0, :branches [[[] branch-0]]}}]) + ;; (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0] + ;; [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1] + ;; [[:lang/pm-local [:lang/local 0 11]] 2]) + ;; classify-outer (fn [struct [branch $body]] + ;; (clojure.core.match/match branch + ;; [::pm-variant ?tag ?members] + ;; (update-in struct [:cases ?tag] conj {:members ?members + ;; :body $body}) + + ;; [::pm-text ?text] + ;; (update-in struct [:tests] conj {:test [::text ?text] + ;; :body $body}) + + ;; [::pm-local ?binding] + ;; (assoc struct :default {:storage ?binding + ;; :body $body}))) + ;; outer-classification (reduce classify-outer + ;; {:cases {} + ;; :tests '() + ;; :default nil} + ;; data) + ;; full-classifier (fn full-classifier [global] + ;; (prn 'full-classifier global) + ;; (let [subcases (:cases global)] + ;; (if (empty? subcases) + ;; global + ;; (let [crossed (sort (fn [x1 x2] (> (-> x1 second :cases count) (-> x2 second :cases count))) + ;; (for [[tag subs] subcases + ;; :let [_ (prn 'subcases tag subs)] + ;; :let [parts (for [cross (apply map list (map :members subs)) + ;; :let [_ (prn 'cross tag cross)] + ;; ;; :let [_ (prn '(map :body subs) (map :body subs))] + ;; ;; :let [_ (prn (class cross) (count cross) + ;; ;; (class (map :body subs)) (count (map :body subs)))] + ;; :let [cross+ (map vector cross (map :body subs))] + ;; ;; :let [_ (prn 'cross+ tag (class cross+) (count cross+))] + ;; ;; :let [_ (prn 'cross+ tag cross+)] + ;; :let [cross++ (reduce classify-outer + ;; {:cases {} + ;; :tests '() + ;; :default nil} + ;; cross+)] + ;; ;; :let [_ (prn 'cross++ tag cross++)] + ;; ] + ;; cross++)] + ;; :let [_ (prn 'parts parts)]] + ;; [tag parts])) + + ;; ] + ;; (assoc global :cases (reduce (fn [tree [tag subcases]] + ;; (update-in tree [tag] #(conj (or % []) (full-classifier subcases)))) + ;; {} + ;; crossed))))))] + ;; (full-classifier outer-classification)) + ) - ;; {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]}, - ;; "Nil" {:arity 0, :branches [[[] branch-0]]}} - - - ;; ......................... - - ;; (case elems - ;; #Nil - ;; elems - - ;; (#Cons head tail) - ;; (case head - ;; (#Cons (#Symbol "~") (#Cons unquoted #Nil)) - ;; (#Cons unquoted (template tail)) - - ;; (#Cons (#Symbol "~@") (#Cons spliced #Nil)) - ;; (#Cons (#Symbol "++") (#Cons spliced (template tail))) - - ;; _ - ;; (#Cons head (template tail))) - ;; ) - - ;; Total registers: 3 - ;; [{:tag "Nil" :data [] :path path-1} - ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}] - - ;; {path-0 [:branch "Nil" []] - ;; path-1 [:branch "Cons" [[:bind head] [:bind tail]]]} - - ;; Total registers: 6 - ;; {path-0 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]]] - ;; path-1 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]] - ;; path-2 [:default _]} - - ;; {"#default#" [:default path-2 _] - ;; "Cons" [:branches [path-0 path-1] - ;; [[[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]] - ;; [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]]]} - - ;; [:branches] +(comment + [{2 [:lang.parser/variant "Cons" ([:lang.parser/ident "head"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])], + 1 [:lang.parser/variant "Cons" ([:lang.parser/variant "Symbol" ([:lang.parser/string "++"])] [:lang.parser/variant "Cons" ([:lang.parser/ident "spliced"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])])], + 0 [:lang.parser/variant "Cons" ([:lang.parser/ident "unquoted"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])]} + {:type :lang/adt*, + :patterns {"Cons" ({:type :lang/adt*, + :patterns {"Symbol" ({:type :lang/text-tests, + :patterns {"~@" #{1}, + "~" #{0}}, + :defaults [], + :branches #{0 1}})}, + :default nil, + :branches #{0 1}} + {:type :lang/adt*, + :patterns {"Cons" ({:type :lang/defaults, + :stores {[:lang/local 0 11] #{0 1}}, + :branches #{0 1}} + {:type :lang/adt*, + :patterns {"Nil" ()}, + :default nil, + :branches #{0 1}})}, + :default nil, + :branches #{0 1}})}, + :default [:lang/default [:lang/local 0 11] 2], + :branches #{0 1 2}}] - - ;; (case elems - ;; #Nil - ;; elems - - ;; (#Cons (list (' ~) unquoted) tail) - ;; (list* unquoted (template tail)) - - ;; (#Cons (list (' ~@) spliced) tail) - ;; (list* "++" spliced (template tail)) - - ;; _ - ;; (#Cons head (template tail)) - ;; ) - - ;; [{:tag "Nil" :data [] :path path-1} - ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}] - - ;; [[{:tag "Cons" :data [%0 %1] :path nil - ;; :sub-cases [[{:tag "Symbol" :data [[:string-cmp "~"]] :path path-1} - ;; {:tag "Symbol" :data [[:string-cmp "~@"]] :path path-2}] - ;; [{:tag "Cons" :data [[:bind unquoted] {:tag "Nil" :data []}] :path path-1} - ;; {:tag "Cons" :data [[:bind spliced] {:tag "Nil" :data []}] :path path-2}]]} - ;; {:tag ::default :path path-3}]] - - ;; [[["Cons" ["Symbol" "~"] ["Cons" unquoted ["Nil"]]] - ;; ["Cons" ["Symbol" "~@"] ["Cons" spliced ["Nil"]]] - ;; _]] - - ;; [[["Symbol" "~"] - ;; ["Symbol" "~@"]] - ;; [["Cons" unquoted ["Nil"]] - ;; ["Cons" spliced ["Nil"]]]] - - ;; (if (= "Cons" (:: % tag)) - ;; (let [%0 (:: % _0) - ;; %1 (:: % _1)] - ;; (if (= "Symbol" (:: %0 tag)) - ;; (let [%0|0 (:: %0 _0)] - ;; (if (= "~" %0|0) - ;; (if (= "Cons" (:: %1 tag)) - ;; (let [%1|0 (:: %1 _0) - ;; %1|1 (:: %1 _1)] - ;; (if (= "Nil" (:: %1|1 tag)) - ;; (let [unquoted %1|0] - ;; <path-1>) - ;; <path-3>)) - ;; <path-3>) - ;; (if (= "@~" %0|0) - ;; (if (= "Cons" (:: %1 tag)) - ;; (let [%1|0 (:: %1 _0) - ;; %1|1 (:: %1 _1)] - ;; (if (= "Nil" (:: %1|1 tag)) - ;; (let [unquoted %1|0] - ;; <path-2>) - ;; <path-3>)) - ;; <path-3>) - ;; <path-3>))) - ;; <path-3>)) - ;; <path-3>) - + (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0] + [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1] + [[:lang/pm-local [:lang/local 0 11]] 2]) + ] + (generate-branches data)) + + ;; (def (workday? d) + ;; (case d + ;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] + ;; true) + ;; (or [#Saturday #Sunday] + ;; false))) - - ;; (list (list '["Nil" [] ...] - ;; '["Cons" [head tail] ...])) - - ;; (list (list '["Cons" [["Symbol" ["~"]] ["Cons" [unquoted ["Nil" []]]]] ...] - ;; '["Cons" [["Symbol" ["~@"]] ["Cons" [spliced ["Nil" []]]]] ...])) ) - 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 "<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] |