diff options
Diffstat (limited to 'src/lang')
| -rw-r--r-- | src/lang/analyser.clj | 33 | ||||
| -rw-r--r-- | src/lang/compiler.clj | 111 |
2 files changed, 100 insertions, 44 deletions
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index 7c94c77d5..64bdbac9b 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -445,21 +445,36 @@ (with-anon-locals num-members (fn [=locals] ;; (prn '?branch/=locals (map :form =locals)) - (exec [=members (reduce-m (fn [[locals-map =members] [?local ?member]] - (match ?member - [::&parser/ident ?name] - (return [(assoc locals-map ?name ?local) (conj =members (:form ?local))]))) - [{} []] - (map vector =locals ?members)) + (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/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 (first =members) + =body (with-locals locals+ (analyse-form* ?body)) ;; :let [_ (prn '?body ?body =body)] ] - (return [num-members [::branch-adt ?tag (second =members) =body]]))))))) + (return [(+ num-members inner-num) [::branch-adt ?tag members+ =body]]))))))) ?branches)] (return [(first =locals) =branches])))) - :let [total-registers (reduce + 1 (map first =branches)) + :let [total-registers (+ 1 (reduce max 0 (map first =branches))) ;; _ (prn '=branches total-registers (map second =branches)) ;; _ (assert false) ] diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index e425fa0f1..f26d111a4 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -288,46 +288,87 @@ (defcompiler ^:private compile-case ;; [::&analyser/case ?variant ?branches] [::&analyser/case ?base ?variant ?registers ?branches] - (do ;; (prn [:case ?base ?variant ?registers ?branches]) - (match (:form ?base) - [::&analyser/local _ ?base-idx] - (let [start-label (new Label) - end-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)) - (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx) - (let [variant-class* (->class +variant-class+)] + (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] - (let [tuple-class (str "test2/Tuple" (count ?members))] - (when (not (empty? ?members)) - (do (doto *writer* - (.visitVarInsn Opcodes/ALOAD ?base-idx) - (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object")) - (.visitTypeInsn Opcodes/CHECKCAST tuple-class)) - (doseq [[?tfield member] (map vector (range (count ?members)) ?members)] - (match member - [:lang.analyser/local 0 ?idx] + (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)] + (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)) + + [::&analyser/subcase ?subtag ?submembers] + (let [tuple-class* (str "test2/Tuple" (count ?submembers)) + cleanup-label (new Label)] + (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* - (.visitInsn Opcodes/DUP) - (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object")) - (.visitVarInsn Opcodes/ASTORE ?idx)))) - (.visitInsn *writer* Opcodes/POP))) - (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 (compile-form (assoc *state* :form ?body))) - (.visitJumpInsn Opcodes/GOTO end-label) - (.visitLabel else-label)))))) - (.visitInsn *writer* Opcodes/ACONST_NULL) - (.visitLabel *writer* end-label))) + (.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 default-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))) ))) (defcompiler ^:private compile-let |