From 9b0c07dbf78bbdb6e13fbbd44e02fe322d9f145c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 8 Mar 2015 02:20:51 -0400 Subject: - Changed once more the syntax of the prefix for host special forms. It's now "jvm-" instead of "jvm;" - Fixed the bug where the same local vars/registers were getting registered more than once and the class-verifier complained. - Fixed a bug where the "end label" for pattern-matching bodies was never inserted. - Simplified the analyser by removing "self" calls and having self be just a local for the "this" object (register 0). - Removed the lambda-folding optimization. - The compiler state now holds and environment for naming globally-scoped lambdas. --- source/lux.lux | 1299 +++++++++++++++++++------------------------ src/lux.clj | 2 +- src/lux/analyser.clj | 60 +- src/lux/analyser/case.clj | 4 +- src/lux/analyser/env.clj | 12 +- src/lux/analyser/lambda.clj | 267 +-------- src/lux/analyser/lux.clj | 76 ++- src/lux/compiler.clj | 7 +- src/lux/compiler/base.clj | 105 +++- src/lux/compiler/case.clj | 7 +- src/lux/compiler/lambda.clj | 194 ++----- src/lux/compiler/lux.clj | 91 +-- src/lux/macro.clj | 5 +- src/lux/optimizer.clj | 1 + 14 files changed, 829 insertions(+), 1301 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 641be09ca..7cafb2977 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,5 +1,5 @@ ## Base interfaces & classes -(jvm;interface Function +(jvm-interface Function (: apply (-> [java.lang.Object] java.lang.Object))) ## Base functions & macros @@ -18,9 +18,9 @@ (lambda' _ tokens (lambda' _ state (let' output (case' tokens - (#Cons [(#Form (#Cons [self (#Cons [arg args'])])) (#Cons [body #Nil])]) + (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])]) (#Form (#Cons [(#Ident "lambda'") - (#Cons [self + (#Cons [(#Ident "") (#Cons [arg (#Cons [(case' args' #Nil @@ -28,7 +28,21 @@ _ (#Form (#Cons [(#Ident "lux;lambda") - (#Cons [(#Form (#Cons [(#Ident "_") args'])) + (#Cons [(#Tuple args') + (#Cons [body #Nil])])]))) + #Nil])])])])) + + (#Cons [(#Ident self) (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])])]) + (#Form (#Cons [(#Ident "lambda'") + (#Cons [(#Ident self) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (#Form (#Cons [(#Ident "lux;lambda") + (#Cons [(#Tuple args') (#Cons [body #Nil])])]))) #Nil])])])]))) [(#Cons [output #Nil]) state]) @@ -36,7 +50,7 @@ (declare-macro lambda) (def' def - (lambda (_ tokens state) + (lambda [tokens state] (let' output (case' tokens (#Cons [(#Ident name) (#Cons [body #Nil])]) (#Form (#Cons [(#Ident "def'") tokens])) @@ -46,44 +60,48 @@ (#Form (#Cons [(#Ident "def'") (#Cons [(#Ident name) (#Cons [(#Form (#Cons [(#Ident "lux;lambda") - (#Cons [(#Form (#Cons [(#Ident name) args])) - (#Cons [body #Nil])])])) + (#Cons [(#Ident name) + (#Cons [(#Tuple args) + (#Cons [body #Nil])])])])) #Nil])])]))) [(#Cons [output #Nil]) state]))) (declare-macro def) -## (def (defmacro tokens state) -## (let' fn-def (case' tokens -## (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) -## (#Cons [body #Nil])]) -## (#Form (#Cons [(#Form (#Cons [(#Ident "lux;def") -## (#Cons [(#Ident ?name) -## (#Cons [(#Ident ?tokens) -## (#Cons [(#Ident ?state) -## #Nil])])])])) -## (#Cons [body -## #Nil])]))) -## (let' declaration [] -## [(#Cons [fn-def (#Cons [declaration #Nil])]) state]))) -## (declare-macro defmacro) - -(def (comment tokens state) +(def (defmacro tokens state) + (let' [fn-name fn-def] (case' tokens + (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) + (#Cons [body #Nil])]) + [?name + (#Form (#Cons [(#Ident "lux;def") + (#Cons [(#Form (#Cons [(#Ident ?name) + (#Cons [(#Ident ?tokens) + (#Cons [(#Ident ?state) + #Nil])])])) + (#Cons [body + #Nil])])]))]) + (let' declaration (#Form (#Cons [(#Ident "declare-macro") (#Cons [(#Ident fn-name) #Nil])])) + [(#Cons [fn-def (#Cons [declaration #Nil])]) state]))) +(declare-macro defmacro) + +(defmacro (comment tokens state) [#Nil state]) -(declare-macro comment) -(def (+ x y) - (jvm;iadd x y)) +(def (int+ x y) + (jvm-iadd x y)) (def (id x) x) (def (print x) - (jvm;invokevirtual java.io.PrintStream "print" [java.lang.Object] - (jvm;getstatic java.lang.System "out") [x])) + (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] + (jvm-getstatic java.lang.System "out") [x])) (def (println x) - (jvm;invokevirtual java.io.PrintStream "println" [java.lang.Object] - (jvm;getstatic java.lang.System "out") [x])) + (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] + (jvm-getstatic java.lang.System "out") [x])) + +#( + (def (fold f init xs) (case' xs @@ -94,13 +112,14 @@ (fold f (f init x) xs'))) (def (reverse list) - (fold (lambda (_ tail head) (#Cons [head tail])) + (fold (lambda [tail head] + (#Cons [head tail])) #Nil list)) (def (list xs state) (let' xs' (reverse xs) - (let' output (fold (lambda (_ tail head) + (let' output (fold (lambda [tail head] (#Form (#Cons [(#Tag "Cons") (#Cons [(#Tuple (#Cons [head (#Cons [(#Form (#Cons [(#Tag "Cons") @@ -117,7 +136,8 @@ [#Nil state] (#Cons [last init']) - (let' output (fold (lambda (_ tail head) + (let' output (fold (lambda [tail head] + ## (#Form (list (#Tag "Cons") (#Tuple (list head tail)))) (#Form (#Cons [(#Tag "Cons") (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) #Nil])]))) last init') @@ -135,7 +155,7 @@ (def (let tokens state) (case' tokens (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) - (let' output (fold (lambda (_ body binding) + (let' output (fold (lambda [body binding] (case' binding [label value] (#Form (list (#Ident "let'") label value body)))) @@ -144,734 +164,553 @@ [(list output) state]))) (declare-macro let) -(def (++-list xs ys) +(def (++ xs ys) (case' xs #Nil ys (#Cons [x xs*]) - (#Cons [x (++-list xs* ys)]))) + (#Cons [x (++ xs* ys)]))) -(def (map-list f xs) +(def (map f xs) (case' xs #Nil #Nil (#Cons [x xs*]) - (#Cons [(f x) (map-list f xs*)]))) - -#( -(def (untemplate-list untemplate tokens) -(case tokens -#Nil -(#Tag "Nil") + (#Cons [(f x) (map f xs*)]))) -(#Cons token tokens') -(#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) +(def (filter p xs) + (case' xs + #Nil + #Nil -(def (untemplate token) -(case token -(#Bool elem) -(#Form (list (#Tag "Bool") (#Bool elem))) + (#Cons [x xs*]) + (if (p x) + (filter p xs*) + (#Cons [x (filter p xs*)])))) +)# -(#Int elem) -(#Form (list (#Tag "Int") (#Int elem))) +#((def (untemplate-list untemplate tokens) + (case tokens + #Nil + (#Tag "Nil") -(#Real elem) -(#Form (list (#Tag "Real") (#Real elem))) + (#Cons [token tokens']) + (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) -(#Char elem) -(#Form (list (#Tag "Char") (#Char elem))) +(def (untemplate token) + (case token + (#Bool elem) + (#Form (list (#Tag "Bool") (#Bool elem))) -(#Text elem) -(#Form (list (#Tag "Text") (#Text elem))) + (#Int elem) + (#Form (list (#Tag "Int") (#Int elem))) -(#Tag elem) -(#Form (list (#Tag "Tag") (#Text elem))) + (#Real elem) + (#Form (list (#Tag "Real") (#Real elem))) -(#Ident elem) -(#Form (list (#Tag "Ident") (#Text elem))) + (#Char elem) + (#Form (list (#Tag "Char") (#Char elem))) -(#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) -unquoted + (#Text elem) + (#Form (list (#Tag "Text") (#Text elem))) -(#Tuple elems) -(#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) + (#Tag elem) + (#Form (list (#Tag "Tag") (#Text elem))) -(#Form elems) -(#Form (list (#Tag "Form") (untemplate-list untemplate elems))) -)) + (#Ident elem) + (#Form (list (#Tag "Ident") (#Text elem))) + (#Form (#Cons [(#Ident "~") (#Cons [unquoted #Nil])])) + unquoted -## I/O -(def (print x) -(jvm;invokevirtual java.io.PrintStream "print" [Object] -(jvm;getstatic System out) [x])) + (#Tuple elems) + (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) -(def (println x) -(jvm;invokevirtual java.io.PrintStream "println" [Object] -(jvm;getstatic System out) [x])) + (#Form elems) + (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) + )) -(def (' form) -(case form -(#Cons token #Nil) -(untemplate token))) +(def (' tokens state) + [(map untemplate tokens) state]) (declare-macro ') -(def (+ x y) -(jvm;iadd x y)) +## TODO: Full pattern-matching +## TODO: Type-related macros +## TODO: (Im|Ex)ports-related macros +## TODO: Macro-related macros -(def inc (+ 1)) +(def (return val) + (lambda [state] + [state val])) -(def length (fold (lambda' l (lambda' x (inc l))) 0)) +(def (bind f v) + (lambda [state] + (case (v state) + [state' x] + ((f x) state')))) -(def (rem dividend divisor) -(jvm;irem dividend divisor)) - -(def (= x y) -(jvm;invokevirtual Object "equals" [Object] -x [y])) - -(def (pairs list) -(case list -(#Cons x (#Cons y list*)) -(#Cons [x y] (pairs list*)) - -_ -#Nil)) - -(def (show x) -(jvm;invokevirtual Object "toString" [] -x [])) +(def (if tokens) + (case' tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (' (case' (~ test) + true (~ then) + false (~ else))))))) +(declare-macro if) + +(def (apply-template env template) + (case template + (#Ident ident) + (if-let [subst (get ident env)] + subst + template) + + (#Tuple elems) + (#Tuple (map (apply-template env) elems)) + + (#Form elems) + (#Form (map (apply-template env) elems)) + + (#Record members) + (#Record (map (lambda [kv] + (case kv + [slot value] + [(apply-template env slot) (apply-template env value)])) + members)) + + _ + template)) + +(def (do-template tokens) + (case tokens + (list+ bindings template data) + (let [bindings-list (tuple->list bindings) + data-lists (map tuple->list data)] + (return (map (lambda [env] (apply-template env template)) + (map (zip 2 bindings) data-lists)))))) +(declare-macro do-template) + +(def gen-ident + (lambda [state] + [(update@ #gen-seed inc state) + (#Ident ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) + +(do-template [ ] + (def ( pair) + (case' pair + [f s] + )) + + [first f] + [second s]) + +(def (loop tokens) + (case' tokens + (#Cons [bindings (#Cons [body #Nil])]) + (let [pairs (as-pairs bindings)] + (return (list (' ((lambda (~ (#Ident "recur")) (~ (#Tuple (map first pairs))) + (~ body)) + (~@ (map second pairs))))))))) +(declare-macro loop) + +(def (case tokens) + (case' tokens + (#Cons value branches) + (loop [kind #Pattern + pieces branches + new-pieces (list)] + (case' pieces + #Nil + (return (list (' (case' (~ value) (~@ new-pieces))))) + + (#Cons piece pieces') + (let [[kind' expanded more-pieces] (case' kind + #Body + [#Pattern (list piece) #Nil] + + #Pattern + (do [expansion (macro-expand piece)] + (case' expansion + #Nil + [#Pattern #Nil #Nil] + + (#Cons exp #Nil) + [#Body (list exp) #Nil] + + (#Cons exp exps) + [#Body (list exp) exps])) + )] + (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) + ))) +(declare-macro case) + +(def (do tokens state) + (case tokens + (list (#Tuple bindings) body) + (let [output (fold (lambda [inner binding] + (case binding + [lhs rhs] + (' (bind (lambda [(~ lhs)] (~ body)) + (~ rhs))))) + body + (reverse (as-pairs bindings)))] + [(list output) state]))) +(declare-macro do) + +(def (export tokens) + (return (map (lambda [t] + (' (export' (~ t)))) + tokens))) +(declare-macro export) + +## (import "lux") +## (module-alias "lux" "l") +## (def-alias "lux;map" "map") + +## (def (require tokens) +## (case tokens +## ...)) + +## (require lux #as l #refer [map]) + +(def (type tokens) + (case tokens + (#Tuple elems) + (return (list (' (#Tuple (~ (map untemplate elems)))))) + + (#Record fields) + (return (list (' (#Record (~ (map (lambda [kv] + (case kv + [(#Tag tag) val] + [tag (untemplate val)])) + fields)))))) + + (#Form (list+ (#Ident "|") options)) + (do [options' (map% (lambda [opt] + (case opt + (#Tag tag) + [tag (#Tuple (list))] + + (#Form (list (#Tag tag) value)) + [tag value] + + _ + (fail ""))) + options)] + (#Variant options')) + )) +(declare-macro type) + +## (type (| #Nil +## (#Cons [a (List a)]))) + +## (type [Int Bool Text]) + +## (type {#id Int #alive? Bool #name Text}) + +(def (All tokens) + (let [[name args body] (case tokens + (list (#Tuple args) body) + ["" args body] + + (list (#Ident name) (#Tuple args) body) + [name args body])] + (return (list (' (#All (~ name) [(~@ (map (lambda [arg] + (case arg + (#Ident arg') + (#Text arg'))) + args))] + (~ body))))))) +(declare-macro All) + +(def (Exists tokens) + (case tokens + (list (#Ident name) body) + (return (list (' (#Exists (~ name) (~ body))))))) +(declare-macro Exists) + +(def (deftype tokens) + (case tokens + (list (#Ident name) definition) + (return (list (' (def (~ (#Ident name)) + (type (~ definition)))))) + + (list (#Form (list+ (#Ident name) args)) definition) + (let [name' (#Ident name)] + (return (list (' (def (~ name') + (All (~ name') [(~@ args)] + (type (~ definition)))))))) + )) +(declare-macro deftype) + +(def (and tokens) + (let [as-if (case tokens + #Nil + (' true) + + (#Cons init tests) + (fold (lambda [prev next] + (' (if (~ prev) (~ next) false))) + init + tokens) + )] + (return (list as-if)))) +(declare-macro and) + +(def (or tokens) + (let [as-if (case tokens + #Nil + (' false) + + (#Cons init tests) + (fold (lambda [prev next] + (' (if (~ prev) true (~ next)))) + init + tokens) + )] + (return (list as-if)))) +(declare-macro or) + +(def (not x) + (case x + true false + false true)) + +(def (get@ tokens) + (let [output (case tokens + (list (#Tag tag) record) + (' (get@' (~ (#Tag tag)) (~ record))) + + (list (#Tag tag)) + (' (lambda [record] (get@' (~ (#Tag tag)) record))))] + (return (list output)))) +(declare-macro get@) + +(def (set@ tokens) + (let [output (case tokens + (list (#Tag tag) value record) + (' (set@' (~ (#Tag tag)) (~ value) (~ record))) + + (list (#Tag tag) value) + (' (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) + + (list (#Tag tag)) + (' (lambda [value record] (set@' (~ (#Tag tag)) value record))))] + (return (list output)))) +(declare-macro set@) + +(def (update@ tokens) + (let [output (case tokens + (list tag func record) + (` (let [_record_ (~ record)] + (set@ (~ tag) _record_ ((~ func) (get@ (~ tag) _record_))))) + + (list (#Tag tag) func) + (' (lambda [record] + (` (set@ (~ tag) record ((~ func) (get@ (~ tag) record)))))) + + (list (#Tag tag)) + (' (lambda [func record] + (set@ (~ tag) record (func (get@ (~ tag) record))))))] + (return (list output)))) +(declare-macro update@) + +(def (. f g) + (lambda [x] (f (g x)))) + +(def (|> tokens) + (case tokens + (list+ init apps) + (return (list (fold (lambda [acc app] + (case app + (#Form parts) + (#Form (++ parts (list acc))) + + _ + (` (~ app) (~ acc)))) + init + apps))))) + +(def ($ tokens) + (case tokens + (list+ op init args) + (return (list (fold (lambda [acc elem] + (` (~ op) (~ acc) (~ elem))) + init + args))))) + +(def ($keys tokens) + (case tokens + (list (#Tuple fields)) + (let [record (#Record (map (lambda [slot] + (case slot + (#Tag name) + [(#Tag name) (#Ident name)])) + fields))] + (return (list record))))) + +(def ($or tokens) + (case tokens + (list (#Tuple patterns) body) + (return (flat-map (lambda [pattern] (list pattern body)) + patterns)))) + +(def (-> tokens) + (case (reverse tokens) + (#Cons [f-return f-args]) + (fold (lambda [f-return f-arg] + (#Lambda [f-arg f-return])) + f-return f-args))) + +(def (defsyntax tokens) + ...) + +(def (defsig tokens) + ...) + +(def (defstruct tokens) + ...) + +(def (with tokens) + ...) -(def (concat t1 t2) -(jvm;invokevirtual String "concat" [String] -t1 [t2])) +## (deftype (List a) +## (| #Nil +## (#Cons [a (List a)]))) + +(def (complement f) + (lambda [x] (not (f x)))) + +(def (cond tokens) + (let [else (last tokens) + branches (as-pairs (init tokens))] + (return (list (fold (lambda [else branch] + (case branch + [test then] + (` (if (~ test) (~ then) (~ else))))) + else + branches))))) +(declare-macro cond) + +(def (constant x) + (lambda [_] x)) + +(def (repeat n x) + (if (> n 0) + (list+ x (repeat (dec n) x)) + #Nil)) + +(def (size xs) + (case xs + #Nil 0 + (#Cons [_ xs']) (int+ 1 (size xs')))) + +(def (last xs) + (case xs + #Nil #None + (list x) (#Some x) + (list+ _ xs') (last xs'))) + +(def (init xs) + (case xs + #Nil #None + (list _) (#Some #Nil) + (#Cons [x xs']) (case (init xs') + (#Some xs'') + (#Cons [x xs'']) + + _ + #None))) + +(do-template [ ] + (def (int+ )) + + [inc 1] + [dec -1]) + +(def (interleave xs ys) + (case [xs ys] + [(#Cons [x xs']) (#Cons [y ys'])] + (list+ x y (interleave xs' ys')) + + _ + #Nil)) + +(def (interpose sep xs) + (case xs + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list+ x sep (interpose sep xs')) + + _ + xs)) + +(def (flatten xss) + (fold ++ (list) xs)) + +(def (flat-map f xs) + (flatten (map f xs))) + +(do-template [ ] + (def ( x y) + (if ( x y) + x + y)) + + [max >] + [min <]) + +(do-template [ ] + (def ( n) ( n 0)) + + [neg? <] + [pos? >=]) + +(def (even? n) + (int= 0 (int% n 0))) + +(def (odd? n) + (not (even? n))) + +(do-template [ ] + (def ( n xs) + (if (> n 0) + (case xs + #Nil #Nil + (list+ x xs') ) + )) + + [take #Nil (list+ x (take (dec n) xs'))] + [drop xs (drop (dec n) xs')]) + +(do-template [ ] + (def ( f xs) + (case xs + #Nil #Nil + (list+ x xs') (if (f x) #Nil))) + + [take-while #Nil (list+ x (take-while f xs'))] + [drop-while xs (drop-while f xs')]) + +(def (empty? xs) + (case xs + #Nil true + _ false)) + +(do-template [ ] + (def ( p xs) + (case xs + #Nil true + (#Cons [x xs']) ( (p x) ( p xs')))) + + [every? and] + [any? or]) (def (range from to) -(if (= from to) -#Nil -(#Cons from (range (inc from) to)))) - -(def (text->list text) -(let' length (jvm;invokevirtual String "length" [] -text []) -(map (lambda' idx -(jvm;invokevirtual String "charAt" [int] -text [idx])) -(range 0 length)))) - -(def (enumerate list) -(case (fold (lambda' state -(lambda' x -(case state -[idx list'] -[(inc idx) (#Cons [idx x] list')]))) -[0 #Nil] -list) -[_ list'] -(reverse list'))) - -(def list-map #Nil) - -(def (put key val map) -(case map -#Nil -(#Cons [key val] map) - -(#Cons [?key ?val] map') -(if (= key ?key) -(#Cons [?key val] map') -(#Cons [?key ?val] (put key val map'))))) - -(def (get key map) -(case map -#Nil -#None - -(#Cons [?key ?val] map') -(if (= key ?key) -(#Some ?val) -(get key map')))) - -(def (show-kv kv) -(case kv -[?key ?val] -(fold concat "" (list "#" ?key " " (show ?val))))) - -(def (interpose elem list) -(case list -(#Cons x (#Cons y list')) -(list+ x elem y (interpose elem list')) - -_ -list)) - -(def (show-list xs) -(case xs -#Nil -"#Nil" - -(#Cons x xs') -(fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) - -(defsig (Equal x) -(: = (-> x x Bool))) - -(deftype Equal (All [x r] {#= (-> x x Bool) & r})) -(deftype Equal (All [x] {#= (-> x x Bool)})) -(deftype Equal (All [x] (Exists [r] {#= (-> x x Bool) & r}))) - -(defimpl (Equal Bool) -(def (= x y) -(case [x y] -[ true true] true -[false false] true -_ false))) - -(def Equal_Bool -(struct {#= [(-> Bool Bool Bool) -(lambda [x y] ...)]})) - -(: (~ g!Equal) (Equal Bool)) -(: (~ g!Equal) {#= (-> Bool Bool Bool)}) -(def (~ g!Equal) -{#= (lambda [x y] ...)}) - -(def Equal_List -(lambda [Equal_x] -(struct {#= }))) - -(: Equal_List -(All [x] (-> (Equal x) (Equal (List x))))) - -(defimpl (All [x] -(=> [(Equal x)] -(Equal (List x)))) -(def (= xs1 xs2) -(case [xs1 xs2] -[#Nil #Nil] -true - -[(#Cons x1 xs1') (#Cons x2 xs2')] -(and (Equal_x x1 x2) (= xs1' xs2'))))) - -(All [x] -(-> (Equal x) (Equal (List x)))) - -(EqualList EqualBool) => {#= ...} - -(: ops (List (Exists [a] [(-> Text a) (-> a [])]))) -(def ops (list [(lambda [_] 10) (lambda [_] [])] -[(lambda [_] "") (lambda [_] [])])) - -(case ops -#Nil -[] - -(#Cons [f1 f2] ops') -(f2 (f1 "E"))) - -(defsig (Add x) -(: + (-> x x x))) - -(defimpl AddInt (Add Int) -#defs -(def (+ x y) -(jvm;ladd x y))) - -(defimpl (Add Int) -(def (+ x y) -(jvm;ladd x y))) - -(: adder (All [x] (=> [(Add x)] -(-> x (-> x x))))) -(def (adder by) -(lambda [x] (+ by x))) - -(adder AddInt 1) -> (lambda [x] ((get@ #+ AddInt) 1 x)) -adder == (lambda [impl] -(case impl -{#+ +} -(lambda [x] (+ by x)))) - -(: calc (All [v] -(-> (-> v Int) -(| (#Add Int Int) (#Mul Int Int) & v) -Int))) -(def (calc backup expr) -(case expr -(#Add x y) (+ x y) -(#Mul x y) (* x y) -else (backup else))) - -(defsig Yolo -(: lol? (-> Text Bool)) -(: foo Int)) - -(defimpl Meme [Yolo] -(def (lol? _) true) -(def foo 10)) - -(defimpl Nyan [Yolo] -Meme -(def foo 20)) - -(list 1 2 3) == (#Cons 1 (#Cons 2 (#Cons 3 #Nil))) -(list+ 1 2 (list 3)) - -(defsig (Monoid a) -(: empty a) -(: ++ (BinaryOp a))) - -(: concat (All [a] -(=> [(Monoid a)] -(-> (List a) a)))) -(def (concat mon -xs) -(fold (:: mon #++) (:: mon #empty) xs)) - -(defstruct (Monoid Text) -(def empty "") -(def (++ x y) -...)) - -(defstruct (All [a] -(Monoid (List a))) -(def empty (list)) -(def (++ xs ys) -(case xs -#Nil -ys - -(#Cons x xs') -(#Cons x (++ xs' ys))))) - -(: map (All [a b] (-> (-> a b) (List a) (List b)))) - -(defsig (Collection c) -(: add (All [x] (-> x (c x) (c x)))) -(: length (All [x] (-> (c x) Int)))) - -(defclass (Stack s) -(: push (All [x] (-> x (s x) (s x)))) -(: pop (All [x] (-> (s x) (s x)))) -(: peek (All [x] (-> (s x) (Maybe x))))) - -(deftype (BinaryOp t) -(-> t t t)) - -(defclass (Number n) -(: + (BinaryOp n)) -(: - (BinaryOp n)) -(: * (BinaryOp n)) -(: / (BinaryOp n))) - -(def (flip f) -(lambda [x y] -(f y x))) - -(def (concat' xss) -(case (reverse xss) -#Nil -#Nil - -(#Cons xs xss') -(fold (flip ++) xs xss'))) - -n + n*m - -(with [AddInt] -(+ 10 20)) - -(:: AddInt (+ 10 20)) == ((get@ AddInt #=) 10 20) - -(defimpl (Stack List) -(def (push x xs) -(#Cons x xs)) - -(def (pop xs) -(case xs -#Nil #Nil -(#Cons _ xs') xs')) - -(def (peek xs) -(case xs -#Nil #None -(#Cons x _) (#Some x)))) - -(defsig (Functor f) -(: map (All [a b] (-> (-> a b) (f a) (f b))))) - -(def (Functor f) -{#map (All [a b] (-> (-> a b) (f a) (f b)))}) - -(defimpl ListFunctor (Functor List) -(def (map func fa) -(case fa -#Nil -#Nil - -(list a fa') -(list (func a) (map func fa'))))) - -(implicit ListFunctor -(map inc (list 1 2 3))) - -(defsig (=> [(Functor m)] -(Monad m)) -(: return (All [x] (-> x (m x)))) -(: bind (All [a b] (-> (m a) (-> a (m b)) (m b))))) - - - -(#User {#name Text #age Int}) -(deftype User {#name Text #age Int}) -(deftype User (& (#name Text) -(#age Int))) -(deftype User (All [r] -(& (#name Text) -(#age Int) -++ r))) -(def User (#Record (list ["name" Text] ["age" Int]))) - -(let [thunk (... (+ 5 6))] -(! thunk)) - -(Thunk Int) - - -(deftype Int&Bool [Int Bool]) - -(deftype (List a) -(| #Nil -(#Cons a (List a)))) - -(defclass (Equal a) -(: = (-> a a Bool))) -== -(deftype (Equal a) -{#= (-> a a Bool)}) - -(def Equals -(All [a] {#= (-> a a Bool)})) - -(defimpl EqualBool [(Equal Bool)] -(def (= x y) -(if x -y -(not y)))) - -(def ... {#= (lambda [x y] (if x -y -(not y)))}) - -(def Class (All [I] -(Exists [S] (& (#state S) -(#methods (I S)))))) - -(definterface Vector -(: translate (BinaryOp Vector))) - -(def Vector (Some [Vector] -(& (#translate (BinaryOp v))))) - -(defclass Vector2D -{#x Real, #y Real} -(def (new-Vector2D x y) -{#x x, #y y}) -Vector -(def (translate self offset) -(-> self -(update@ #x + (get@ offset #x)) -(update@ #y + (get@ offset #y))))) - -(def Vector2D -{#translate (: (lambda [self offset] -(-> self -(update@ #x +real (get@ offset #x)) -(update@ #y +real (get@ offset #y)))) -(BinaryOp {#x Real, #y Real}))}) - -(: new-Vector2D (-> Real Real [{#x Real, #y Real} (@class Vector2D)])) -(def (new-Vector2D x y) -[{#x x, #y y} Vector2D]) - -(defsig (Vector v) -(: translate (BinaryOp v)) -(: scale (BinaryOp v))) - -(def Vector (All Vector [v] -(& (#translate (BinaryOp v)) -(#scale (BinaryOp v))))) - -(defstruct Vector2D (Vector [Real Real]) -(def (translate [x1 y1] [x2 y2]) -[(+ x1 x2) (+ y1 y2)]) -(def (scale [x1 y1] [x2 y2]) -[(* x1 x2) (* y1 y2)])) - -(def Vector2D (: {#translate (lambda [[x1 y1] [x2 y2]] -[(+real x1 x2) (+real y1 y2)]) -#scale (lambda [[x1 y1] [x2 y2]] -[(*real x1 x2) (*real y1 y2)])} -(Vector [Real Real]))) - -(deftype (Stream a) -(| (#Cons a (Thunk (Stream a))))) - -(: iterate (All [a] (-> (-> a a) a (Stream a)))) -(def (iterate f init) -(list init (... (iterate f (f init))))) - -(def (take n stream) -(if (<= n 0) -#Nil -(case stream -(#Cons x stream') -(#Cons x (take (dec n) stream'))))) - -(deftype (Stream a) -(All [b] (-> (-> a (Stream a b) b) b))) - -(: iterate (All [a] (-> (-> a a) a (Stream a)))) -(def (iterate f init) -(lambda [k] -(k init (iterate f (f init))))) - -(def (repeat x) -(lambda [k] (k x (repeat x)))) - -(def (take n stream) -(if (<= n 0) -#Nil -(stream (lambda [x stream'] -(#Cons x (take (dec n) stream')))))) - -(defsig (Comonad w) -(: extract (All [a] (-> (w a) a))) -(: extend (All [a b] (-> (w a) (-> (w a) b) (w b))))) - -(defstruct Stream (Comonad w) -(def (extract stream) -(stream (lambda [x _] x))) -(def (extend w f) -...)) - -(: fibonacci (Stream Int)) -(def fibonacci ((lambda fibonacci [a b] -(lambda [k] (k a (fibonacci b (+ a b))))) -0 1)) - -(gen fibonacci [a 0 b 1] -(yield a (fibonacci b (+ a b)))) - -(defgen fibonacci [a 0 b 1] -(yield a (fibonacci b (+ a b)))) - -(gen fibonacci [a 0 b 1] -(yield a [b (+ a b)])) - -## The dual of do-notation should be be-notation - -(deftype (Stream a) -(| (#Cons a (Thunk (Stream a))))) - -(defstruct (Functor Stream) -(def (map f s) -(lambda [k] -(stream (lambda [x stream'] -(f s)))))) - -(deftype (Tape a) -(| (#Index (Thunk (Stream a)) a (Thunk (Stream a))))) - -(deftype (Area a) -(| (#Cursor (Tape a) (Surreal a)))) - -(def (ints offset n) -(#Index (... (iterate (lambda [n'] (- n' offset)) n)) -n -(... (iterate (+ offset) n)))) - -(def (reals offset x) -(#Cursor (ints offset x) -(reals (/ offset 10) 0))) + (if (< from to) + (list+ from (range (inc from) to)) + #Nil)) )# - -#( -(deftype (Session i o s) -(All [s' r] -(-> (-> i s' r) -(-> o s [i s']) -r)) - -(All [s' s''] (-> (-> c s' [p s'']) -(-> [] s [c s']) (Session c p s) -[p s''])) -(All [] (-> (-> c s p) -(-> p []))) -(All [r] (-> c (Session r p s) p))) - -(Session Int [] (Session Int (Session [] Int ))) - -(bind (session' []) -(lambda [x session'] -(bind (session' []) -(lambda [y session''] -(session'' (+ x y)))))) - -(defstruct SessionMonad -(Monad Session) -(def (return v) -(lambda [k session] -(k v session))) -(def (bind step m-value) -(lambda [k session] -(let [[v session'] (m-value [] session)] -(k (step v) session'))))) - -## Not really "do"; but oh, well... - -(deftype -(| #Nil)) - -(deftype (HList h t) -(| (#Cons h t))) - -(deftype (Session c p s) -(All [r] (-> c (-> p s r) r))) - -(deftype (Session c p s) -(-> (-> p s c) c)) - -(deftype (? r s) -(Session r [] s)) - -(deftype (! w s) -(Session [] w s)) - -(deftype #rec -(Session [] [] )) - -(def << -(lambda [k session] -(k [] session))) - -(def (>> val) -(lambda [k session] -(session val k))) - -(<$> << (>> 5)) - -(def (<$> consumer producer) -(producer [] consumer)) - -(HList Int (HList Int )) - -(<.> (? Int) (? Int) (! Int) ) -(def fn-session -(do [x << -y <<] -(>> (+ x y)))) - -(<.> (! Int) (! Int) (? Int) ) -(def call-session -(do [_ (>> 5) -_ (>> 10)] -<<)) - -(<$> fn-session call-session) - -(def << -(lambda [chan] -(chan (lambda [])))) - -(def (>> value) -(lambda [chan] -(chan value))) -)# - -## (defsig (Equal a) -## (: = (-> a a Bool))) - -## (: not= (All [a] (-> (Equal a) a a Bool))) -## (def (not= &Equal -## x x) -## (not (:: &Equal (= x x)))) - -## (defstruct Int -## [] -## (Equal Int) - -## (def (= x y) -## (zero? (- x y)))) - -## (defsig (Show a) -## (: show (-> a Text))) - -## (defstruct (ListShow x) -## [&show (Show a)] -## (Show (List a)) - -## (def (show xs) -## (<> "(" (interpose ", " (map (:: &show show) xs)) ")"))) - -## (def ListShow -## (: (lambda [&show] -## {#show (lambda show [xs] -## (<> "(" (interpose ", " (map (:: &show show) xs)) ")"))}) -## (-> (Show a) (Show (List a))))) - -## (deftype (Identity a) a) - -## (deftype (List a) -## (| #Nil -## (#Cons a (List a)))) - -## (def (ListT m) -## (All [a] (List (m a)))) - -## (ListT Identity) - -## (defsig (Monad m) -## (: return (All [a] (-> a (m a)))) -## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) - -## (def Monad -## (All [m] -## (sig (: return (All [a] (-> a (m a)))) -## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))))) - -## (defstruct Monad (Monad Identity) -## (def (return x) -## x) -## (def (bind f x) -## (f x))) - -## (: Monad (Monad Identity)) -## (def Monad -## (struct -## (def (return x) -## x) -## (def (bind f x) -## (f x)))) - -## (defstruct Monad (All [m] (-> (Monad m) -## (Monad (ListT m)))) -## (def (return x) -## (list x)) -## (def (bind f xs) -## (case xs -## #Nil #Nil -## (#Cons x xs') (#Cons (f x) (bind f xs'))))) - -## (deftype #rec Type -## ($data #Any -## #Nothing -## (#Data Text (List Type)) -## (#Lambda Type Type) -## (#All (List [Text Type]) Text Text Type) -## (#Exists (List [Text Type]) Text Type) -## (#Lookup Text) -## (#Var Int))) diff --git a/src/lux.clj b/src/lux.clj index 66cb929a4..ce843d0cd 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -11,7 +11,7 @@ ;; TODO: throw, try, catch, finally ;; TODO: Allow setting fields. ;; TODO: monitor enter & monitor exit. - ;; TODO: + ;; TODO: Add column & line numbers for syntactic elements. ;; TODO: ;; TODO: ;; TODO: diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4ddd8ecd1..3575c3007 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -63,100 +63,100 @@ (&&host/analyse-exec analyse-ast ?exprs) ;; Integer arithmetic - [::&parser/Form ([[::&parser/Ident "jvm;iadd"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-iadd"] ?x ?y] :seq)] (&&host/analyse-jvm-iadd analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;isub"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-isub"] ?x ?y] :seq)] (&&host/analyse-jvm-isub analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;imul"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-imul"] ?x ?y] :seq)] (&&host/analyse-jvm-imul analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;idiv"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-idiv"] ?x ?y] :seq)] (&&host/analyse-jvm-idiv analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;irem"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-irem"] ?x ?y] :seq)] (&&host/analyse-jvm-irem analyse-ast ?x ?y) ;; Long arithmetic - [::&parser/Form ([[::&parser/Ident "jvm;ladd"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-ladd"] ?x ?y] :seq)] (&&host/analyse-jvm-ladd analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;lsub"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-lsub"] ?x ?y] :seq)] (&&host/analyse-jvm-lsub analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;lmul"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-lmul"] ?x ?y] :seq)] (&&host/analyse-jvm-lmul analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;ldiv"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-ldiv"] ?x ?y] :seq)] (&&host/analyse-jvm-ldiv analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;lrem"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-lrem"] ?x ?y] :seq)] (&&host/analyse-jvm-lrem analyse-ast ?x ?y) ;; Float arithmetic - [::&parser/Form ([[::&parser/Ident "jvm;fadd"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-fadd"] ?x ?y] :seq)] (&&host/analyse-jvm-fadd analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;fsub"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-fsub"] ?x ?y] :seq)] (&&host/analyse-jvm-fsub analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;fmul"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-fmul"] ?x ?y] :seq)] (&&host/analyse-jvm-fmul analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;fdiv"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-fdiv"] ?x ?y] :seq)] (&&host/analyse-jvm-fdiv analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;frem"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-frem"] ?x ?y] :seq)] (&&host/analyse-jvm-frem analyse-ast ?x ?y) ;; Double arithmetic - [::&parser/Form ([[::&parser/Ident "jvm;dadd"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-dadd"] ?x ?y] :seq)] (&&host/analyse-jvm-dadd analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;dsub"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-dsub"] ?x ?y] :seq)] (&&host/analyse-jvm-dsub analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;dmul"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-dmul"] ?x ?y] :seq)] (&&host/analyse-jvm-dmul analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;ddiv"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-ddiv"] ?x ?y] :seq)] (&&host/analyse-jvm-ddiv analyse-ast ?x ?y) - [::&parser/Form ([[::&parser/Ident "jvm;drem"] ?x ?y] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-drem"] ?x ?y] :seq)] (&&host/analyse-jvm-drem analyse-ast ?x ?y) ;; Fields & methods - [::&parser/Form ([[::&parser/Ident "jvm;getstatic"] [::&parser/Ident ?class] [::&parser/Text ?field]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-getstatic"] [::&parser/Ident ?class] [::&parser/Text ?field]] :seq)] (&&host/analyse-jvm-getstatic analyse-ast ?class ?field) - [::&parser/Form ([[::&parser/Ident "jvm;getfield"] [::&parser/Ident ?class] [::&parser/Text ?field] ?object] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-getfield"] [::&parser/Ident ?class] [::&parser/Text ?field] ?object] :seq)] (&&host/analyse-jvm-getfield analyse-ast ?class ?field ?object) - [::&parser/Form ([[::&parser/Ident "jvm;invokestatic"] [::&parser/Ident ?class] [::&parser/Text ?method] [::&parser/Tuple ?classes] [::&parser/Tuple ?args]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-invokestatic"] [::&parser/Ident ?class] [::&parser/Text ?method] [::&parser/Tuple ?classes] [::&parser/Tuple ?args]] :seq)] (&&host/analyse-jvm-invokestatic analyse-ast ?class ?method ?classes ?args) - [::&parser/Form ([[::&parser/Ident "jvm;invokevirtual"] [::&parser/Ident ?class] [::&parser/Text ?method] [::&parser/Tuple ?classes] ?object [::&parser/Tuple ?args]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-invokevirtual"] [::&parser/Ident ?class] [::&parser/Text ?method] [::&parser/Tuple ?classes] ?object [::&parser/Tuple ?args]] :seq)] (&&host/analyse-jvm-invokevirtual analyse-ast ?class ?method ?classes ?object ?args) ;; Arrays - [::&parser/Form ([[::&parser/Ident "jvm;new"] [::&parser/Ident ?class] [::&parser/Tuple ?classes] [::&parser/Tuple ?args]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-new"] [::&parser/Ident ?class] [::&parser/Tuple ?classes] [::&parser/Tuple ?args]] :seq)] (&&host/analyse-jvm-new analyse-ast ?class ?classes ?args) - [::&parser/Form ([[::&parser/Ident "jvm;new-array"] [::&parser/Ident ?class] [::&parser/Int ?length]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-new-array"] [::&parser/Ident ?class] [::&parser/Int ?length]] :seq)] (&&host/analyse-jvm-new-array analyse-ast ?class ?length) - [::&parser/Form ([[::&parser/Ident "jvm;aastore"] ?array [::&parser/Int ?idx] ?elem] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-aastore"] ?array [::&parser/Int ?idx] ?elem] :seq)] (&&host/analyse-jvm-aastore analyse-ast ?array ?idx ?elem) - [::&parser/Form ([[::&parser/Ident "jvm;aaload"] ?array [::&parser/Int ?idx]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-aaload"] ?array [::&parser/Int ?idx]] :seq)] (&&host/analyse-jvm-aaload analyse-ast ?array ?idx) ;; Classes & interfaces - [::&parser/Form ([[::&parser/Ident "jvm;class"] [::&parser/Ident ?name] [::&parser/Ident ?super-class] [::&parser/Tuple ?fields]] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-class"] [::&parser/Ident ?name] [::&parser/Ident ?super-class] [::&parser/Tuple ?fields]] :seq)] (&&host/analyse-jvm-class analyse-ast ?name ?super-class ?fields) - [::&parser/Form ([[::&parser/Ident "jvm;interface"] [::&parser/Ident ?name] & ?members] :seq)] + [::&parser/Form ([[::&parser/Ident "jvm-interface"] [::&parser/Ident ?name] & ?members] :seq)] (&&host/analyse-jvm-interface analyse-ast ?name ?members) _ diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 639395f33..5227bfcb0 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -26,9 +26,9 @@ (defn analyse-branch [analyse max-registers [bindings body]] ;; (prn 'analyse-branch max-registers bindings body) (reduce (fn [body* name] - (&env/with-local name :local &type/+dont-care-type+ body*)) + (&env/with-local name &type/+dont-care-type+ body*)) (reduce (fn [body* _] - (&env/with-local "#" :local &type/+dont-care-type+ body*)) + (&env/with-local "" &type/+dont-care-type+ body*)) (&&/analyse-1 analyse body) (range (- max-registers (count bindings)))) (reverse bindings))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 55205e597..5b52e3db3 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -10,18 +10,12 @@ (fn [state] [::&/ok [state (-> state ::&/local-envs first :locals :counter)]])) -(defn with-local [name mode type body] +(defn with-local [name type body] (fn [state] (let [old-mappings (-> state ::&/local-envs first (get-in [:locals :mappings])) =return (body (update-in state [::&/local-envs] (fn [[top & stack]] - ;; (prn 'env/with-local name mode (get-in top [:locals :counter])) - (let [bound-unit (case mode - :local [::&&/local (get-in top [:locals :counter])] - - ;; else - [::&&/self (second mode) (list)] - )] + (let [bound-unit [::&&/local (get-in top [:locals :counter])]] (cons (-> top (update-in [:locals :counter] inc) (assoc-in [:locals :mappings name] [::&&/Expression bound-unit type])) @@ -40,7 +34,7 @@ (defn with-locals [locals monad] (reduce (fn [inner [label elem]] - (with-local label :local elem inner)) + (with-local label elem inner)) monad (reverse locals))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index c0af66050..61daa5e5f 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -10,8 +10,8 @@ (defn with-lambda [self self-type arg arg-type body] (&/with-closure (exec [scope-name &/get-scope-name] - (&env/with-local self [:self scope-name] self-type - (&env/with-local arg :local arg-type + (&env/with-local self self-type + (&env/with-local arg arg-type (exec [=return body =captured &env/captured-vars] (return [scope-name =captured =return]))))))) @@ -23,266 +23,3 @@ [register* (update-in frame [:closure] #(-> % (update-in [:counter] inc) (assoc-in [:mappings ident] register*)))]))) - -(defn raise-expr [out-scope arg syntax] - (match syntax - [::&&/Expression ?form ?type] - (match ?form - [::&&/bool ?value] - syntax - - [::&&/int ?value] - syntax - - [::&&/real ?value] - syntax - - [::&&/char ?value] - syntax - - [::&&/text ?value] - syntax - - [::&&/tuple ?members] - [::&&/Expression [::&&/tuple (map (partial raise-expr out-scope arg) ?members)] ?type] - - [::&&/variant ?tag ?value] - [::&&/Expression [::&&/variant ?tag (raise-expr out-scope arg ?value)] ?type] - - [::&&/local ?idx] - [::&&/Expression [::&&/local (inc ?idx)] ?type] - - [::&&/captured _ _ ?source] - ?source - - [::&&/self ?scope ?curried] - [::&&/Expression [::&&/self out-scope (cons arg (map (partial raise-expr out-scope arg) ?curried))] ?type] - - [::&&/global _ _] - syntax - - [::&&/case ?variant ?base ?num-bindings ?branches] - [::&&/Expression [::&&/case (raise-expr out-scope arg ?variant) (inc ?base) ?num-bindings - (for [[?pattern ?body] ?branches] - [?pattern (raise-expr out-scope arg ?body)])] - ?type] - - [::&&/lambda ?scope ?captured ?args ?value] - [::&&/Expression [::&&/lambda (rest ?scope) - (into {} (for [[?name ?sub-syntax] ?captured] - [?name (raise-expr out-scope arg ?sub-syntax)])) - ?args - ?value] - ?type] - - [::&&/call ?func ?args] - [::&&/Expression [::&&/call (raise-expr out-scope arg ?func) (map (partial raise-expr out-scope arg) ?args)] ?type] - - [::&&/exec ?asts] - [::&&/Expression [::&&/exec (map (partial raise-expr out-scope arg) ?asts)] ?type] - - [::&&/jvm-getstatic _ _] - syntax - - [::&&/jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args] - [::&&/Expression [::&&/jvm-invokevirtual ?class ?method ?arg-classes - (raise-expr out-scope arg ?obj) - (map (partial raise-expr out-scope arg) ?args)] - ?type] - - ;; Integer arithmetic - [::&&/jvm-iadd ?x ?y] - [::&&/Expression [::&&/jvm-iadd (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-isub ?x ?y] - [::&&/Expression [::&&/jvm-isub (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-imul ?x ?y] - [::&&/Expression [::&&/jvm-imul (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-idiv ?x ?y] - [::&&/Expression [::&&/jvm-idiv (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-irem ?x ?y] - [::&&/Expression [::&&/jvm-irem (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - ;; Long arithmetic - [::&&/jvm-ladd ?x ?y] - [::&&/Expression [::&&/jvm-ladd (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-lsub ?x ?y] - [::&&/Expression [::&&/jvm-lsub (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-lmul ?x ?y] - [::&&/Expression [::&&/jvm-lmul (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-ldiv ?x ?y] - [::&&/Expression [::&&/jvm-ldiv (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-lrem ?x ?y] - [::&&/Expression [::&&/jvm-lrem (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - ;; Float arithmetic - [::&&/jvm-fadd ?x ?y] - [::&&/Expression [::&&/jvm-fadd (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-fsub ?x ?y] - [::&&/Expression [::&&/jvm-fsub (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-fmul ?x ?y] - [::&&/Expression [::&&/jvm-fmul (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-fdiv ?x ?y] - [::&&/Expression [::&&/jvm-fdiv (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-frem ?x ?y] - [::&&/Expression [::&&/jvm-frem (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - ;; Double arithmetic - [::&&/jvm-dadd ?x ?y] - [::&&/Expression [::&&/jvm-dadd (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-dsub ?x ?y] - [::&&/Expression [::&&/jvm-dsub (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-dmul ?x ?y] - [::&&/Expression [::&&/jvm-dmul (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-ddiv ?x ?y] - [::&&/Expression [::&&/jvm-ddiv (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - - [::&&/jvm-drem ?x ?y] - [::&&/Expression [::&&/jvm-drem (raise-expr out-scope arg ?x) (raise-expr out-scope arg ?y)] ?type] - ))) - -(defn re-scope [out-scope syntax] - (let [partial-f (partial re-scope out-scope)] - (match syntax - [::&&/Expression ?form ?type] - (match ?form - [::&&/bool ?value] - syntax - - [::&&/int ?value] - syntax - - [::&&/real ?value] - syntax - - [::&&/char ?value] - syntax - - [::&&/text ?value] - syntax - - [::&&/tuple ?members] - [::&&/Expression [::&&/tuple (map partial-f ?members)] ?type] - - [::&&/variant ?tag ?value] - [::&&/Expression [::&&/variant ?tag (partial-f ?value)] ?type] - - [::&&/local ?idx] - [::&&/Expression [::&&/local ?idx] ?type] - - [::&&/captured _ _ ?source] - ?source - - [::&&/self ?scope ?curried] - [::&&/Expression [::&&/self out-scope (map partial-f ?curried)] ?type] - - [::&&/global _ _] - syntax - - [::&&/case ?variant ?base ?num-bindings ?branches] - [::&&/Expression [::&&/case (partial-f ?variant) ?base ?num-bindings - (for [[?pattern ?body] ?branches] - [?pattern (partial-f ?body)])] - ?type] - - [::&&/lambda ?scope ?captured ?args ?value] - [::&&/Expression [::&&/lambda (rest ?scope) - (into {} (for [[?name ?sub-syntax] ?captured] - [?name (partial-f ?sub-syntax)])) - ?args - ?value] - ?type] - - [::&&/call ?func ?args] - [::&&/Expression [::&&/call (partial-f ?func) (map partial-f ?args)] ?type] - - [::&&/exec ?asts] - [::&&/Expression [::&&/exec (map partial-f ?asts)] ?type] - - [::&&/jvm-getstatic _ _] - syntax - - [::&&/jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args] - [::&&/Expression [::&&/jvm-invokevirtual ?class ?method ?arg-classes - (partial-f ?obj) - (map partial-f ?args)] - ?type] - - ;; Integer arithmetic - [::&&/jvm-iadd ?x ?y] - [::&&/Expression [::&&/jvm-iadd (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-isub ?x ?y] - [::&&/Expression [::&&/jvm-isub (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-imul ?x ?y] - [::&&/Expression [::&&/jvm-imul (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-idiv ?x ?y] - [::&&/Expression [::&&/jvm-idiv (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-irem ?x ?y] - [::&&/Expression [::&&/jvm-irem (partial-f ?x) (partial-f ?y)] ?type] - - ;; Long arithmetic - [::&&/jvm-ladd ?x ?y] - [::&&/Expression [::&&/jvm-ladd (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-lsub ?x ?y] - [::&&/Expression [::&&/jvm-lsub (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-lmul ?x ?y] - [::&&/Expression [::&&/jvm-lmul (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-ldiv ?x ?y] - [::&&/Expression [::&&/jvm-ldiv (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-lrem ?x ?y] - [::&&/Expression [::&&/jvm-lrem (partial-f ?x) (partial-f ?y)] ?type] - - ;; Float arithmetic - [::&&/jvm-fadd ?x ?y] - [::&&/Expression [::&&/jvm-fadd (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-fsub ?x ?y] - [::&&/Expression [::&&/jvm-fsub (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-fmul ?x ?y] - [::&&/Expression [::&&/jvm-fmul (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-fdiv ?x ?y] - [::&&/Expression [::&&/jvm-fdiv (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-frem ?x ?y] - [::&&/Expression [::&&/jvm-frem (partial-f ?x) (partial-f ?y)] ?type] - - ;; Double arithmetic - [::&&/jvm-dadd ?x ?y] - [::&&/Expression [::&&/jvm-dadd (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-dsub ?x ?y] - [::&&/Expression [::&&/jvm-dsub (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-dmul ?x ?y] - [::&&/Expression [::&&/jvm-dmul (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-ddiv ?x ?y] - [::&&/Expression [::&&/jvm-ddiv (partial-f ?x) (partial-f ?y)] ?type] - - [::&&/jvm-drem ?x ?y] - [::&&/Expression [::&&/jvm-drem (partial-f ?x) (partial-f ?y)] ?type] - )))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 5e81cae0e..570048dcd 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -23,29 +23,34 @@ (return (list [::&&/Expression [::&&/tuple =elems] [::&type/Tuple =elems-types]])))) (defn analyse-ident [analyse ident] - (fn [state] - (let [[top & stack*] (::&/local-envs state)] - (if-let [=bound (or (get-in top [:locals :mappings ident]) - (get-in top [:closure :mappings ident]))] - [::&/ok [state (list =bound)]] - (let [no-binding? #(and (-> % :locals :mappings (contains? ident) not) - (-> % :closure :mappings (contains? ident) not)) - [inner outer] (split-with no-binding? stack*)] - (if (empty? outer) - (if-let [global (get-in state [::&/global-env ident])] - [::&/ok [state (list global)]] - [::&/failure (str "[Analyser Error] Unresolved identifier: " ident)]) - (let [[=local inner*] (reduce (fn [[register new-inner] frame] - (let [[register* frame*] (&&lambda/close-over (:name frame) ident register frame)] - [register* (cons frame* new-inner)])) - [(or (get-in (first outer) [:locals :mappings ident]) - (get-in (first outer) [:closure :mappings ident])) - '()] - (reverse (cons top inner)))] - [::&/ok [(assoc state ::&/local-envs (concat inner* outer)) (list =local)]]) - )) - )) - )) + (exec [module-name &/get-module-name] + (fn [state] + (let [[top & stack*] (::&/local-envs state)] + (if-let [=bound (or (get-in top [:locals :mappings ident]) + (get-in top [:closure :mappings ident]))] + [::&/ok [state (list =bound)]] + (let [no-binding? #(and (-> % :locals :mappings (contains? ident) not) + (-> % :closure :mappings (contains? ident) not)) + [inner outer] (split-with no-binding? stack*)] + (if (empty? outer) + (if-let [global (get-in state [::&/global-env ident])] + [::&/ok [state (list global)]] + [::&/failure (str "[Analyser Error] Unresolved identifier: " ident)]) + (let [in-stack (cons top inner) + scopes (rest (reductions #(cons (:name %2) %1) (map :name outer) (reverse in-stack))) + _ (prn 'in-stack module-name ident (map :name in-stack) scopes) + [=local inner*] (reduce (fn [[register new-inner] [frame in-scope]] + (let [[register* frame*] (&&lambda/close-over (cons module-name (reverse in-scope)) ident register frame)] + [register* (cons frame* new-inner)])) + [(or (get-in (first outer) [:locals :mappings ident]) + (get-in (first outer) [:closure :mappings ident])) + '()] + (map vector (reverse in-stack) scopes) + )] + [::&/ok [(assoc state ::&/local-envs (concat inner* outer)) (list =local)]]) + )) + )) + ))) (defn analyse-call [analyse =fn ?args] (exec [loader &/loader] @@ -84,7 +89,7 @@ ;; :let [_ (prn '[branches locals-per-branch max-locals] [branches locals-per-branch max-locals])] base-register &&env/next-local-idx ;; :let [_ (prn 'base-register base-register)] - =variant (reduce (fn [body* _] (&&env/with-local "#" :local &type/+dont-care-type+ body*)) + =variant (reduce (fn [body* _] (&&env/with-local "" &type/+dont-care-type+ body*)) (&&/analyse-1 analyse ?variant) (range max-locals)) ;; :let [_ (prn '=variant =variant)] @@ -104,16 +109,8 @@ (&&/analyse-1 analyse ?body)) =body-type (&&/expr-type =body) =lambda-type (exec [_ (&type/solve =return =body-type)] - (&type/clean =lambda-type)) - :let [=lambda-form (match =body - [::&&/Expression [::&&/lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] _] - [::&&/lambda =scope =captured (cons ?arg ?sub-args) (&&lambda/raise-expr =scope ?arg ?sub-body)] - - _ - [::&&/lambda =scope =captured (list ?arg) =body]) - ;; _ (prn '=lambda-form =lambda-form) - ]] - (return (list [::&&/Expression =lambda-form =lambda-type])))) + (&type/clean =lambda-type))] + (return (list [::&&/Expression [::&&/lambda =scope =captured ?arg =body] =lambda-type])))) (defn analyse-def [analyse ?name ?value] ;; (prn 'analyse-def ?name ?value) @@ -121,17 +118,6 @@ (if-m (&&def/defined? module-name ?name) (fail (str "[Analyser Error] Can't redefine " ?name)) (exec [=value (&&/analyse-1 analyse ?value) - =value (match =value - [::&&/Expression =value-form =value-type] - (return (match =value-form - [::&&/lambda ?old-scope ?env ?args ?body] - [::&&/Expression [::&&/lambda (list module-name ?name) ?env ?args (&&lambda/re-scope (list module-name ?name) ?body)] =value-type] - - _ - =value)) - - _ - (fail "[Analyser Error] def value must be an expression!")) =value-type (&&/expr-type =value) _ (&&def/define module-name ?name =value-type)] (return (list [::&&/Statement [::&&/def ?name =value]])))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index afc232843..503f041ea 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -69,11 +69,8 @@ [::&a/case ?variant ?base-register ?num-registers ?branches] (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches) - [::&a/lambda ?scope ?frame ?args ?body] - (&&lambda/compile-lambda compile-expression ?type ?scope ?frame ?args ?body false true) - - [::&a/self ?scope ?assumed-args] - (&&lux/compile-self-call compile-expression ?scope ?assumed-args) + [::&a/lambda ?scope ?env ?args ?body] + (&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body) ;; Integer arithmetic [::&a/jvm-iadd ?x ?y] diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 28c793e10..394f77d0b 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,24 +1,22 @@ (ns lux.compiler.base (:require [clojure.string :as string] + [clojure.core.match :refer [match]] (lux [base :as & :refer [exec return* return fail fail* repeat-m exhaust-m try-m try-all-m map-m reduce-m apply-m - normalize-ident]])) + normalize-ident]]) + [lux.analyser.base :as &a]) (:import (org.objectweb.asm Opcodes Label ClassWriter MethodVisitor))) -;; [Resources] +;; [Exports] (def local-prefix "l") (def partial-prefix "p") (def closure-prefix "c") (def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") -(defn add-nulls [writer amount] - (dotimes [_ amount] - (.visitInsn writer Opcodes/ACONST_NULL))) - (defn write-file [file data] (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] (.write stream data))) @@ -34,3 +32,98 @@ :let [_ (write-class name bytecode) _ (load-class! loader (string/replace name #"/" "."))]] (return nil))) + +(defn total-locals [expr] + (match expr + [::&a/case ?variant ?base-register ?num-registers ?branches] + (+ ?num-registers (reduce max 0 (map (comp total-locals second) ?branches))) + + [::&a/tuple ?members] + (reduce max 0 (map total-locals ?members)) + + [::&a/variant ?tag ?members] + (reduce max 0 (map total-locals ?members)) + + [::&a/call ?fn ?args] + (reduce max 0 (map total-locals (cons ?fn ?args))) + + [::&a/jvm-iadd ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-isub ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-imul ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-idiv ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-irem ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-ladd ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-lsub ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-lmul ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-ldiv ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-lrem ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-fadd ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-fsub ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-fmul ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-fdiv ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-frem ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-dadd ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-dsub ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-dmul ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-ddiv ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/jvm-drem ?x ?y] + (reduce max 0 (map total-locals (list ?x ?y))) + + [::&a/exec ?exprs] + (reduce max 0 (map total-locals ?exprs)) + + [::&a/jvm-new ?class ?classes ?args] + (reduce max 0 (map total-locals ?args)) + + [::&a/jvm-invokestatic ?class ?method ?classes ?args] + (reduce max 0 (map total-locals ?args)) + + [::&a/jvm-invokevirtual ?class ?method ?classes ?object ?args] + (reduce max 0 (map total-locals ?args)) + + [::&a/jvm-aastore ?array ?idx ?elem] + (reduce max 0 (map total-locals (list ?array ?elem))) + + [::&a/jvm-aaload ?array ?idx] + (total-locals ?array) + + _ + 0)) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 48c52123f..37fe6c61f 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -189,12 +189,7 @@ ;; [Resources] (defn compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] (exec [*writer* &/get-writer - :let [$start (new Label) - $end (new Label) - _ (dotimes [offset ?num-registers] - (let [idx (+ ?base-register offset)] - (.visitLocalVariable *writer* (str &&/local-prefix idx) (&host/->java-sig [::&type/Any]) nil $start $end idx))) - _ (.visitLabel *writer* $start)] + :let [$end (new Label)] _ (compile ?variant) :let [[mappings patterns] (process-branches ?base-register ?branches)] _ (compile-pattern-matching *writer* compile mappings patterns $end) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 9afb2a289..5358519d9 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -23,170 +23,96 @@ (def ^:private clo-field-sig (&host/->type-signature "java.lang.Object")) (def ^:private lambda-return-sig (&host/->type-signature "java.lang.Object")) (def ^:private -return "V") -(def ^:private counter-sig "I") -(def ^:private +datum-sig+ (&host/->type-signature "java.lang.Object")) -(defn ^:private lambda-impl-signature [args] - (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) +(def ^:private lambda-impl-signature + (str (reduce str "(" clo-field-sig) ")" + lambda-return-sig)) -(defn ^:private lambda--signature [closed-over args] - (let [num-args (count args)] - (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) - (if (> num-args 1) - (reduce str counter-sig (repeat (dec num-args) clo-field-sig))) - ")" - -return))) +(defn ^:private lambda--signature [env] + (str "(" (reduce str "" (repeat (count env) clo-field-sig)) ")" + -return)) -(defn ^:private add-lambda- [class class-name closed-over args init-signature] - (let [num-args (count args) - num-mappings (count closed-over)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" init-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD ?captured-id) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] closed-over]))) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig)) - (->> (let [field-name (str &&/partial-prefix clo_idx)] - (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) - (.visitEnd))) - (dotimes [clo_idx (dec num-args)]) - (let [offset (+ 2 num-mappings)])))) - (->> (when (> num-args 1)))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) +(defn ^:private add-lambda- [class class-name env] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (match ?captured + [::&a/Expression [::&a/captured _ ?captured-id ?source] _]) + (doseq [[?name ?captured] env]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) -(do-template [ ] - (defn [writer class-name vars] - (dotimes [idx (count vars)] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str idx) clo-field-sig)))) - - ^:private add-closure-vars &&/closure-prefix - ^:private add-partial-vars &&/partial-prefix - ) - -(defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature] - (let [num-args (count args) - num-captured (dec num-args) - default-label (new Label) - branch-labels (for [_ (range num-captured)] - (new Label))] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil) - (.visitCode) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig) - (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) - (-> (doto (.visitLabel branch-label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (add-closure-vars class-name closed-over) - (.visitLdcInsn (int (inc current-captured))) - (add-partial-vars class-name (take current-captured args)) - (.visitVarInsn Opcodes/ALOAD 1) - (&&/add-nulls (- (dec num-captured) current-captured)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" init-signature) - (.visitInsn Opcodes/ARETURN)) - (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) - (.visitLabel default-label)) - (->> (when (> num-args 1)))) - (.visitVarInsn Opcodes/ALOAD 0) - (add-partial-vars class-name (butlast args)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) +(defn ^:private add-lambda-apply [class class-name env] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" lambda-impl-signature) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) (defn ^:private add-lambda-impl [class compile impl-signature impl-body] (&/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) (.visitCode)) - (exec [;; :let [_ (prn 'add-lambda-impl/_0)] - *writer* &/get-writer - ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] + (exec [*writer* &/get-writer + :let [num-locals (&&/total-locals impl-body) + $start (new Label) + $end (new Label) + _ (doto *writer* + (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig [::&type/Any]) nil $start $end (+ 2 idx)) + (->> (dotimes [idx num-locals]))) + (.visitLabel $start))] ret (compile impl-body) - ;; :let [_ (prn 'add-lambda-impl/_2 ret)] :let [_ (doto *writer* + (.visitLabel $end) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) - (.visitEnd))] - ;; :let [_ (prn 'add-lambda-impl/_3)] - ] + (.visitEnd))]] (return ret)))) -(defn ^:private instance-closure [compile lambda-class closed-over args init-signature] +(defn ^:private instance-closure [compile lambda-class closed-over init-signature] (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (->> closed-over - (sort #(< (-> %1 second :form (nth 2)) - (-> %2 second :form (nth 2)))) + (sort #(match [%1 %2] + [[::&a/Expression [::&a/captured _ ?cid1 _] _] + [::&a/Expression [::&a/captured _ ?cid2 _] _]] + (< ?cid1 ?cid2))) (map-m (fn [[?name ?captured]] - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source] + (match ?captured + [::&a/Expression [::&a/captured _ ?captured-id ?source] _] (compile ?source))))) - :let [num-args (count args) - _ (do (when (> num-args 1) - (.visitInsn *writer* Opcodes/ICONST_0) - (&&/add-nulls *writer* (dec num-args))) - (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature))]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] (return nil))) -(defn ^:private add-lambda- [class class-name args -sig] - (let [num-args (count args)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (doto (.visitInsn Opcodes/ICONST_0) - (&&/add-nulls (dec num-args))) - (->> (when (> num-args 1)))) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" -sig) - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -;; [Resources] -(defn compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?] - ;; (prn 'compile-lambda ?scope ?closure ?args ?body) +;; [Exports] +(defn compile-lambda [compile ?scope ?env ?arg ?body] + (prn 'compile-lambda ?scope ?arg) (exec [:let [lambda-class (&host/location ?scope) - impl-signature (lambda-impl-signature ?args) - -sig (lambda--signature ?closure ?args) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] ?closure]))) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) - (.visitEnd)) - (->> (when (> (count ?args) 1)))) - (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) - (add-lambda- lambda-class ?args -sig)) - (when with-datum?)) - (add-lambda-apply lambda-class ?closure ?args impl-signature -sig) - (add-lambda- lambda-class ?closure ?args -sig) + (match ?captured + [::&a/Expression [::&a/captured _ ?captured-id ?source] _]) + (doseq [[?name ?captured] ?env + ;; :let [_ (prn '?captured ?captured)] + ]))) + (add-lambda-apply lambda-class ?env) + (add-lambda- lambda-class ?env) )] - _ (add-lambda-impl =class compile impl-signature ?body) + _ (add-lambda-impl =class compile lambda-impl-signature ?body) :let [_ (.visitEnd =class)] _ (&&/save-class! lambda-class (.toByteArray =class))] - (if instance? - (instance-closure compile lambda-class ?closure ?args -sig) - (return nil)))) + (instance-closure compile lambda-class ?env (lambda--signature ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 72aff9798..f85d2f7a5 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -21,34 +21,7 @@ ClassWriter MethodVisitor))) -;; [Utils] -(defn ^:private compile-field [compile ?name body] - (exec [*writer* &/get-writer - module-name &/get-module-name - :let [outer-class (&host/->class module-name) - datum-sig (&host/->type-signature "java.lang.Object") - current-class (&host/location (list outer-class ?name)) - _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile body) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! current-class (.toByteArray =class))] - (return nil))) - -;; [Resources] +;; [Exports] (let [+class+ (&host/->class "java.lang.Boolean") +sig+ (&host/->type-signature "java.lang.Boolean")] (defn compile-bool [compile *type* ?value] @@ -114,11 +87,12 @@ (return nil))) (defn compile-captured [compile *type* ?scope ?captured-id ?source] + (prn 'compile-captured ?scope ?captured-id) (exec [*writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD - (normalize-ident ?scope) + (&host/location ?scope) (str &&/closure-prefix ?captured-id) "Ljava/lang/Object;"))]] (return nil))) @@ -138,41 +112,28 @@ ?args)] (return nil))) -(defn compile-def [compile name value] - (exec [value-type (&a/expr-type value)] - (match value - [::&a/Expression ?form _] - (match ?form - [::&a/lambda ?scope ?captured ?args ?body] - (&&lambda/compile-lambda compile value-type ?scope ?captured ?args ?body true false) - - _ - (compile-field compile name value)) - - _ - (fail "Can only define expressions.")))) - -(defn compile-self-call [compile ?scope ?assumed-args] - ;; (prn 'compile-self-call ?scope ?assumed-args) +(defn compile-def [compile ?name ?body] (exec [*writer* &/get-writer - :let [lambda-class (&host/location ?scope)] - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW lambda-class) - (.visitInsn Opcodes/DUP))] - :let [num-args (if (= '("lux" "fold") ?scope) - 3 - (count ?assumed-args)) - init-signature (str "(" (if (> num-args 1) - (reduce str "I" (repeat (dec num-args) (&host/->type-signature "java.lang.Object")))) - ")" - "V") - _ (do (when (> num-args 1) - (.visitInsn *writer* Opcodes/ICONST_0) - (&&/add-nulls *writer* (dec num-args))) - (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature))] - _ (map-m (fn [arg] - (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] - (return ret))) - ?assumed-args)] + module-name &/get-module-name + :let [outer-class (&host/->class module-name) + datum-sig (&host/->type-signature "java.lang.Object") + current-class (&host/location (list outer-class ?name)) + _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (exec [*writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile ?body) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! current-class (.toByteArray =class))] (return nil))) diff --git a/src/lux/macro.clj b/src/lux/macro.clj index e7c54d8ac..7f1e7116b 100644 --- a/src/lux/macro.clj +++ b/src/lux/macro.clj @@ -60,9 +60,8 @@ ;; [Resources] (defn expand [loader macro-class tokens] (let [output (-> (.loadClass loader macro-class) - .getDeclaredConstructors - first - (.newInstance (to-array [(int 0) nil])) + (.getField "_datum") + (.get nil) (.apply (->lux+ ->lux loader tokens)) (.apply nil))] [(->clojure+ ->clojure (aget output 0)) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index be6df920f..0daabe2b5 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -10,6 +10,7 @@ ;; Mutability for performance: do escape analysis to know when data-structures can be mutated in-place without anybody noticing. ;; Avoid (un)boxing: Analyser movement of primitive values to/from functions to known when (un)boxing can be avoided. ;; Pre-compute constant expressions: Find function calls for which all arguments are known at compile-time and pre-calculate everything prior to compilation. +;; Convert pattern-matching on booleans into regular if-then-else structures ;; [Exports] (def optimize &analyser/analyse) -- cgit v1.2.3