diff options
Diffstat (limited to '')
7 files changed, 547 insertions, 21 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux index 858a46c44..c5c4d15ff 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux @@ -34,7 +34,7 @@ (-> Text Phase s (Operation Expression))] Handler)) (function (_ extension-name phase input) - (case (<s>.run input parser) + (case (<s>.run parser input) (#try.Success input') (handler extension-name phase input') diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux index 959cc6375..eed30cf71 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux @@ -11,7 +11,7 @@ ["#." case] ["#." loop] ["//#" /// - ## ["." extension] + ["#." extension] [// [analysis (#+)] ["." synthesis] @@ -63,9 +63,6 @@ (^ (synthesis.function/apply application)) (/function.apply generate application) - ## (#synthesis.Extension extension) - ## (/extension.apply generate extension) - - _ - (undefined) + (#synthesis.Extension extension) + (///extension.apply generate extension) )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux index b0f03106c..3240288f7 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux @@ -70,9 +70,6 @@ _.aaload (_.checkcast //runtime.$Stack))) -(def: left-flag _.aconst-null) -(def: right-flag (_.ldc/string "")) - (def: (path' phase stack-depth @else @end path) (-> Phase Nat Label Label Path (Operation (Instruction Any))) (.case path @@ -142,8 +139,8 @@ (_.goto @else) (_.set-label @success) //runtime.push)))) - ([synthesis.side/left ..left-flag function.identity] - [synthesis.side/right ..right-flag .inc]) + ([synthesis.side/left //runtime.left-flag function.identity] + [synthesis.side/right //runtime.right-flag .inc]) (^ (synthesis.member/left lefts)) (operation@wrap (.let [optimized-projection (.case lefts @@ -151,7 +148,7 @@ _.aaload lefts - //runtime.left)] + //runtime.left-projection)] ($_ _.compose ..peek (_.checkcast //runtime.$Tuple) @@ -164,7 +161,7 @@ ..peek (_.checkcast //runtime.$Tuple) (..ldc/integer lefts) - //runtime.right + //runtime.right-projection //runtime.push)) ## Extra optimization @@ -195,8 +192,8 @@ <projection> (_.astore (unsigned.u1 register)) then!)))) - ([synthesis.member/left //runtime.left] - [synthesis.member/right //runtime.right]) + ([synthesis.member/left //runtime.left-projection] + [synthesis.member/right //runtime.right-projection]) (#synthesis.Alt leftP rightP) (do phase.monad diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux new file mode 100644 index 000000000..b7cc9c9fe --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux @@ -0,0 +1,17 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ## ["#." host] + [// + [runtime (#+ Bundle)]]]) + +(def: #export bundle + Bundle + ($_ dictionary.merge + /common.bundle + ## /host.bundle + )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux new file mode 100644 index 000000000..8759bf2e8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux @@ -0,0 +1,459 @@ +(.module: + [lux (#- Type) + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]] + ["." exception (#+ exception:)]] + [data + ["." product] + [number + ["." i32] + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["." constant] + [encoding + ["." signed (#+ S4)]] + ["." type (#+ Type) + [category (#+ Primitive Class)]]]]] + ["." /// + ["#." value] + ["#." runtime (#+ Operation Phase Bundle Handler)] + ["#." function #_ + ["#" abstract]] + ["//#" /// + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + [extension + ["#extension" /] + ["#." bundle]] + ["/#" // + ["#." synthesis (#+ Synthesis %synthesis)]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation (Instruction Any)))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) + +(def: $Boolean (type.class "java.lang.Boolean" (list))) +(def: $Double (type.class "java.lang.Double" (list))) +(def: $Character (type.class "java.lang.Character" (list))) +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $Object (type.class "java.lang.Object" (list))) +(def: $PrintStream (type.class "java.io.PrintStream" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Error (type.class "java.lang.Error" (list))) + +(def: lux-int + (Instruction Any) + ($_ _.compose + _.i2l + (///value.wrap type.long))) + +(def: jvm-int + (Instruction Any) + ($_ _.compose + (///value.unwrap type.long) + _.l2i)) + +(def: ensure-string + (Instruction Any) + (_.checkcast $String)) + +(def: (predicate instruction) + (-> (-> Label (Instruction Any)) + (Instruction Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + (instruction @then) + (_.getstatic $Boolean "FALSE" $Boolean) + (_.goto @end) + (_.set-label @then) + (_.getstatic $Boolean "TRUE" $Boolean) + (_.set-label @end) + ))) + +(def: unit (_.ldc/string //////synthesis.unit)) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension-name phase [inputS elseS conditionalsS]) + (do /////.monad + [@end ///runtime.forge-label + inputG (phase inputS) + elseG (phase elseS) + conditionalsG+ (: (Operation (List [(List [S4 Label]) + (Instruction Any)])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch) + @branch ///runtime.forge-label] + (wrap [(list@map (function (_ char) + [(signed.s4 (.int char)) @branch]) + chars) + ($_ _.compose + (_.set-label @branch) + branchG + (_.goto @end))]))) + conditionalsS)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + (monad.seq _.monad))]] + (wrap (do _.monad + [@else _.new-label] + ($_ _.compose + inputG (///value.unwrap type.long) _.l2i + (_.lookupswitch @else table) + conditionalsG + (_.set-label @else) + elseG + (_.set-label @end) + )))))])) + +(def: (lux::is [referenceG sampleG]) + (Binary (Instruction Any)) + ($_ _.compose + referenceG + sampleG + (..predicate _.if-acmpeq))) + +(def: (lux::try riskyG) + (Unary (Instruction Any)) + ($_ _.compose + riskyG + (_.checkcast ///function.class) + ///runtime.try)) + +(def: bundle::lux + Bundle + (|> (: Bundle /////bundle.empty) + (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) + (/////bundle.install "is" (binary ..lux::is)) + (/////bundle.install "try" (unary ..lux::try)))) + +(template [<name> <op>] + [(def: (<name> [maskG inputG]) + (Binary (Instruction Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + maskG (///value.unwrap type.long) + <op> (///value.wrap type.long)))] + + [i64::and _.land] + [i64::or _.lor] + [i64::xor _.lxor] + ) + +(template [<name> <op>] + [(def: (<name> [shiftG inputG]) + (Binary (Instruction Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + shiftG ..jvm-int + <op> (///value.wrap type.long)))] + + [i64::left-shift _.lshl] + [i64::arithmetic-right-shift _.lshr] + [i64::logical-right-shift _.lushr] + ) + +(import: #long java/lang/Double + (#static MIN_VALUE java/lang/Double) + (#static MAX_VALUE java/lang/Double)) + +(def: ldc/double + (-> Frac (Instruction Any)) + (|>> constant.double _.ldc/double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary (Instruction Any)) + ($_ _.compose + (..ldc/double <const>) + (///value.wrap type.double)))] + + [f64::smallest (java/lang/Double::MIN_VALUE)] + [f64::min (f.* -1.0 (java/lang/Double::MAX_VALUE))] + [f64::max (java/lang/Double::MAX_VALUE)] + ) + +(template [<name> <type> <op>] + [(def: (<name> [paramG subjectG]) + (Binary (Instruction Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <op> (///value.wrap <type>)))] + + [i64::+ type.long _.ladd] + [i64::- type.long _.lsub] + [i64::* type.long _.lmul] + [i64::/ type.long _.ldiv] + [i64::% type.long _.lrem] + + [f64::+ type.double _.dadd] + [f64::- type.double _.dsub] + [f64::* type.double _.dmul] + [f64::/ type.double _.ddiv] + [f64::% type.double _.drem] + ) + +(def: ldc/integer + (-> (I64 Any) (Instruction Any)) + (|>> .i64 i32.i32 constant.integer _.ldc/integer)) + +(template [<eq> <lt> <type> <cmp>] + [(template [<name> <reference>] + [(def: (<name> [paramG subjectG]) + (Binary (Instruction Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <cmp> + (..ldc/integer <reference>) + (..predicate _.if-icmpeq)))] + + [<eq> +0] + [<lt> -1])] + + [i64::= i64::< type.long _.lcmp] + [f64::= f64::< type.double _.dcmpg] + ) + +(def: (to-string class from) + (-> (Type Class) (Type Primitive) (Instruction Any)) + (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) + +(template [<name> <prepare> <transform>] + [(def: (<name> inputG) + (Unary (Instruction Any)) + ($_ _.compose + inputG + <prepare> + <transform>))] + + [i64::f64 + (///value.unwrap type.long) + ($_ _.compose + _.l2d + (///value.wrap type.double))] + + [i64::char + (///value.unwrap type.long) + ($_ _.compose + _.l2i + _.i2c + (..to-string ..$Character type.char))] + + [f64::i64 + (///value.unwrap type.double) + ($_ _.compose + _.d2l + (///value.wrap type.long))] + + [f64::encode + (///value.unwrap type.double) + (..to-string ..$Double type.double)] + + [f64::decode + ..ensure-string + ///runtime.decode-frac] + ) + +(def: bundle::i64 + Bundle + (<| (/////bundle.prefix "i64") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "and" (binary ..i64::and)) + (/////bundle.install "or" (binary ..i64::or)) + (/////bundle.install "xor" (binary ..i64::xor)) + (/////bundle.install "left-shift" (binary ..i64::left-shift)) + (/////bundle.install "logical-right-shift" (binary ..i64::logical-right-shift)) + (/////bundle.install "arithmetic-right-shift" (binary ..i64::arithmetic-right-shift)) + (/////bundle.install "=" (binary ..i64::=)) + (/////bundle.install "<" (binary ..i64::<)) + (/////bundle.install "+" (binary ..i64::+)) + (/////bundle.install "-" (binary ..i64::-)) + (/////bundle.install "*" (binary ..i64::*)) + (/////bundle.install "/" (binary ..i64::/)) + (/////bundle.install "%" (binary ..i64::%)) + (/////bundle.install "f64" (unary ..i64::f64)) + (/////bundle.install "char" (unary ..i64::char))))) + +(def: bundle::f64 + Bundle + (<| (/////bundle.prefix "f64") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary ..f64::+)) + (/////bundle.install "-" (binary ..f64::-)) + (/////bundle.install "*" (binary ..f64::*)) + (/////bundle.install "/" (binary ..f64::/)) + (/////bundle.install "%" (binary ..f64::%)) + (/////bundle.install "=" (binary ..f64::=)) + (/////bundle.install "<" (binary ..f64::<)) + (/////bundle.install "smallest" (nullary ..f64::smallest)) + (/////bundle.install "min" (nullary ..f64::min)) + (/////bundle.install "max" (nullary ..f64::max)) + (/////bundle.install "i64" (unary ..f64::i64)) + (/////bundle.install "encode" (unary ..f64::encode)) + (/////bundle.install "decode" (unary ..f64::decode))))) + +(def: (text::size inputG) + (Unary (Instruction Any)) + ($_ _.compose + inputG + ..ensure-string + (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) + ..lux-int)) + +(def: no-op (Instruction Any) (_@wrap [])) + +(template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [paramG subjectG]) + (Binary (Instruction Any)) + ($_ _.compose + subjectG <pre-subject> + paramG <pre-param> + <op> <post>))] + + [text::= ..no-op ..no-op + (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) + (///value.wrap type.boolean)] + [text::< ..ensure-string ..ensure-string + (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) + (..predicate _.iflt)] + [text::char ..ensure-string ..jvm-int + (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) + ..lux-int] + ) + +(def: (text::concat [leftG rightG]) + (Binary (Instruction Any)) + ($_ _.compose + leftG ..ensure-string + rightG ..ensure-string + (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) + +(def: (text::clip [startG endG subjectG]) + (Trinary (Instruction Any)) + ($_ _.compose + subjectG ..ensure-string + startG ..jvm-int + endG ..jvm-int + (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) + +(def: index-method (type.method [(list ..$String type.int) type.int (list)])) +(def: (text::index [startG partG textG]) + (Trinary (Instruction Any)) + (do _.monad + [@not-found _.new-label + @end _.new-label] + ($_ _.compose + textG ..ensure-string + partG ..ensure-string + startG ..jvm-int + (_.invokevirtual ..$String "indexOf" index-method) + _.dup + (ldc/integer -1) + (_.if-icmpeq @not-found) + ..lux-int + ///runtime.some-injection + (_.goto @end) + (_.set-label @not-found) + _.pop + ///runtime.none-injection + (_.set-label @end)))) + +(def: bundle::text + Bundle + (<| (/////bundle.prefix "text") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "=" (binary ..text::=)) + (/////bundle.install "<" (binary ..text::<)) + (/////bundle.install "concat" (binary ..text::concat)) + (/////bundle.install "index" (trinary ..text::index)) + (/////bundle.install "size" (unary ..text::size)) + (/////bundle.install "char" (binary ..text::char)) + (/////bundle.install "clip" (trinary ..text::clip))))) + +(def: string-method (type.method [(list ..$String) type.void (list)])) +(def: (io::log messageG) + (Unary (Instruction Any)) + ($_ _.compose + (_.getstatic ..$System "out" ..$PrintStream) + messageG + ..ensure-string + (_.invokevirtual ..$PrintStream "println" ..string-method) + ..unit)) + +(def: (io::error messageG) + (Unary (Instruction Any)) + ($_ _.compose + (_.new ..$Error) + _.dup + messageG + ..ensure-string + (_.invokespecial ..$Error "<init>" ..string-method) + _.athrow)) + +(def: exit-method (type.method [(list type.int) type.void (list)])) +(def: (io::exit codeG) + (Unary (Instruction Any)) + ($_ _.compose + codeG ..jvm-int + (_.invokestatic ..$System "exit" ..exit-method) + _.aconst-null)) + +(def: time-method (type.method [(list) type.long (list)])) +(def: (io::current-time _) + (Nullary (Instruction Any)) + ($_ _.compose + (_.invokestatic ..$System "currentTimeMillis" ..time-method) + (///value.wrap type.long))) + +(def: bundle::io + Bundle + (<| (/////bundle.prefix "io") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "log" (unary ..io::log)) + (/////bundle.install "error" (unary ..io::error)) + (/////bundle.install "exit" (unary ..io::exit)) + (/////bundle.install "current-time" (nullary ..io::current-time))))) + +(def: #export bundle + Bundle + (<| (/////bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge ..bundle::i64) + (dictionary.merge ..bundle::f64) + (dictionary.merge ..bundle::text) + (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux index 87a43fb02..3868b747f 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -3,19 +3,24 @@ [data [binary (#+ Binary)] [number + ["." i32] ["." i64] ["n" nat]]] [target [jvm ["_" instruction (#+ Label Instruction)] + ["." constant] ["." type (#+ Type) ["." category (#+ Method)]]]]] ["." // #_ ["#." value] + ["#." function #_ + ["#" abstract]] ["/#" // ["/#" // [// - [reference (#+ Register)]]]]] + [reference (#+ Register)] + ["." synthesis]]]]] ) (type: #export Byte-Code Binary) @@ -39,6 +44,8 @@ (def: #export class (type.class "LuxRuntime" (list))) +(def: $Text (type.class "java.lang.String" (list))) + (def: #export $Tag type.int) (def: #export $Flag //value.type) (def: #export $Variant (type.array //value.type)) @@ -82,12 +89,62 @@ (def: projection-type (type.method [(list ..$Tuple $Offset) //value.type (list)])) -(def: #export left +(def: #export left-projection (..procedure "left" ..projection-type)) -(def: #export right +(def: #export right-projection (..procedure "right" ..projection-type)) +(def: try-name + "try") + +(def: try-type + (type.method [(list //function.class) ..$Variant (list)])) + +(def: #export try + (_.invokestatic ..class ..try-name ..try-type)) + +(def: #export decode-frac + (..procedure "decode_frac" (type.method [(list ..$Text) ..$Variant (list)]))) + +(def: #export variant + (..procedure "variant" (type.method [(list ..$Tag ..$Flag //value.type) ..$Variant (list)]))) + +(def: ldc/integer + (-> (I64 Any) (Instruction Any)) + (|>> .i64 i32.i32 constant.integer _.ldc/integer)) + +(def: #export left-flag _.aconst-null) +(def: #export right-flag (_.ldc/string "")) + +(def: #export left-injection + (Instruction Any) + ($_ _.compose + (..ldc/integer +0) + ..left-flag + _.dup2-x1 + _.pop2 + ..variant)) + +(def: #export right-injection + (Instruction Any) + ($_ _.compose + (..ldc/integer +1) + ..right-flag + _.dup2-x1 + _.pop2 + ..variant)) + +(def: #export some-injection right-injection) + +(def: #export none-injection + (Instruction Any) + ($_ _.compose + (..ldc/integer +0) + _.aconst-null + (_.ldc/string synthesis.unit) + ..variant)) + (def: #export forge-label (Operation Label) (let [shift (n./ 2 i64.width)] diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 0efa89571..c03076d26 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -5,8 +5,7 @@ [case (#+)] [loop (#+)] [function (#+)] - ## [extension (#+)] - )] + [extension (#+)])] (.module: ["/" lux #* [abstract |