diff options
Diffstat (limited to '')
7 files changed, 480 insertions, 36 deletions
diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux index 10fce7368..59e4b7b44 100644 --- a/stdlib/source/lux/target/jvm/instruction.lux +++ b/stdlib/source/lux/target/jvm/instruction.lux @@ -33,7 +33,7 @@ ["#." constant (#+ UTF8) ["#/." pool (#+ Pool)]] ["." type (#+ Type) - [category (#+ Value' Value Return' Return Method Class)] + [category (#+ Class Object Value' Value Return' Return Method)] ["." reflection] ["." parser]]]]) @@ -511,18 +511,18 @@ (exception.throw ..invalid-lookupswitch [])))) []]]))) -(template [<name> <bytecode>] +(template [<name> <category> <bytecode>] [(def: #export (<name> class) - (-> (Type Class) (Instruction Any)) + (-> (Type <category>) (Instruction Any)) (do ..monad ## TODO: Make sure it"s impossible to have indexes greater than U2. [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] (..nullary (<bytecode> index))))] - [new /bytecode.new] - [anewarray /bytecode.anewarray] - [checkcast /bytecode.checkcast] - [instanceof /bytecode.instanceof] + [new Class /bytecode.new] + [anewarray Object /bytecode.anewarray] + [checkcast Object /bytecode.checkcast] + [instanceof Object /bytecode.instanceof] ) (def: #export (iinc register increase) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux index 97db2b34c..959cc6375 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux @@ -8,8 +8,8 @@ ["#." structure] ["#." reference] ["#." function] - ## ["#." case] - ## ["#." loop] + ["#." case] + ["#." loop] ["//#" /// ## ["." extension] [// @@ -42,20 +42,20 @@ (#reference.Constant constant) (/reference.constant constant)) - ## (^ (synthesis.branch/case case)) - ## (/case.case generate case) + (^ (synthesis.branch/case [valueS pathS])) + (/case.case generate valueS pathS) - ## (^ (synthesis.branch/let let)) - ## (/case.let generate let) + (^ (synthesis.branch/let [inputS register bodyS])) + (/case.let generate inputS register bodyS) - ## (^ (synthesis.branch/if if)) - ## (/case.if generate if) + (^ (synthesis.branch/if [conditionS thenS elseS])) + (/case.if generate conditionS thenS elseS) - ## (^ (synthesis.loop/scope scope)) - ## (/loop.scope generate scope) + (^ (synthesis.loop/scope scope)) + (/loop.scope generate scope) - ## (^ (synthesis.loop/recur updates)) - ## (/loop.recur generate updates) + (^ (synthesis.loop/recur updates)) + (/loop.recur generate updates) (^ (synthesis.function/abstraction abstraction)) (/function.abstraction generate abstraction) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux new file mode 100644 index 000000000..1fe43b8da --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux @@ -0,0 +1,275 @@ +(.module: + [lux (#- Type if let case) + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + [number + ["." i32] + ["n" nat]]] + [target + [jvm + ["." constant] + ["_" instruction (#+ Label Instruction) ("#@." monad)] + ["." type (#+ Type) + [category (#+ Method)]] + [encoding + ["." unsigned]]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." value] + [//// + [reference (#+ Register)] + ["." synthesis (#+ Path Synthesis)] + ["." phase ("operation@." monad) + ["." generation]]]]) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: equals-name + "equals") + +(def: equals-type + (type.method [(list //value.type) type.boolean (list)])) + +(def: (pop-alt stack-depth) + (-> Nat (Instruction Any)) + (.case stack-depth + 0 (_@wrap []) + 1 _.pop + 2 _.pop2 + _ ## (n.> 2) + ($_ _.compose + _.pop2 + (pop-alt (n.- 2 stack-depth))))) + +(def: ldc/integer + (-> (I64 Any) (Instruction Any)) + (|>> .i64 i32.i32 constant.integer _.ldc/integer)) + +(def: ldc/long + (-> (I64 Any) (Instruction Any)) + (|>> .int constant.long _.ldc/long)) + +(def: ldc/double + (-> Frac (Instruction Any)) + (|>> constant.double _.ldc/double)) + +(def: peek + (Instruction Any) + ($_ _.compose + _.dup + (..ldc/integer 0) + _.aaload)) + +(def: pop + (Instruction Any) + ($_ _.compose + (..ldc/integer 1) + _.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 + #synthesis.Pop + (operation@wrap ..pop) + + (#synthesis.Bind register) + (operation@wrap ($_ _.compose + ..peek + (_.astore (unsigned.u1 register)))) + + (^ (synthesis.path/bit value)) + (operation@wrap (.let [jump (.if value _.ifeq _.ifne)] + ($_ _.compose + ..peek + (//value.unwrap type.boolean) + (jump @else)))) + + (^ (synthesis.path/i64 value)) + (operation@wrap ($_ _.compose + ..peek + (//value.unwrap type.long) + (..ldc/long value) + _.lcmp + (_.ifne @else))) + + (^ (synthesis.path/f64 value)) + (operation@wrap ($_ _.compose + ..peek + (//value.unwrap type.double) + (..ldc/double value) + _.dcmpl + (_.ifne @else))) + + (^ (synthesis.path/text value)) + (operation@wrap ($_ _.compose + ..peek + (_.ldc/string value) + (_.invokevirtual ..$Object ..equals-name ..equals-type) + (_.ifeq @else))) + + (#synthesis.Then bodyS) + (do phase.monad + [bodyG (phase bodyS)] + (wrap ($_ _.compose + (..pop-alt stack-depth) + bodyG + (_.goto @end)))) + + (^template [<pattern> <flag> <prepare>] + (^ (<pattern> idx)) + (operation@wrap + (do _.monad + [@success _.new-label + @fail _.new-label] + ($_ _.compose + ..peek + (_.checkcast //runtime.$Variant) + (..ldc/integer (<prepare> idx)) + <flag> + //runtime.case + _.dup + (_.ifnull @fail) + (_.goto @success) + (_.set-label @fail) + _.pop + (_.goto @else) + (_.set-label @success) + //runtime.push)))) + ([synthesis.side/left ..left-flag function.identity] + [synthesis.side/right ..right-flag .inc]) + + (^ (synthesis.member/left lefts)) + (operation@wrap (.let [optimized-projection (.case lefts + 0 + _.aaload + + lefts + //runtime.left)] + ($_ _.compose + ..peek + (_.checkcast //runtime.$Tuple) + (..ldc/integer lefts) + optimized-projection + //runtime.push))) + + (^ (synthesis.member/right lefts)) + (operation@wrap ($_ _.compose + ..peek + (_.checkcast //runtime.$Tuple) + (..ldc/integer lefts) + //runtime.right + //runtime.push)) + + ## Extra optimization + (^ (synthesis.path/seq + (synthesis.member/left 0) + (synthesis.!bind-top register thenP))) + (do phase.monad + [thenG (path' phase stack-depth @else @end thenP)] + (wrap ($_ _.compose + ..peek + (_.checkcast //runtime.$Tuple) + (..ldc/integer 0) + _.aaload + (_.astore (unsigned.u1 register)) + thenG))) + + ## Extra optimization + (^template [<pm> <projection>] + (^ (synthesis.path/seq + (<pm> lefts) + (synthesis.!bind-top register thenP))) + (do phase.monad + [then! (path' phase stack-depth @else @end thenP)] + (wrap ($_ _.compose + ..peek + (_.checkcast //runtime.$Tuple) + (..ldc/integer lefts) + <projection> + (_.astore (unsigned.u1 register)) + then!)))) + ([synthesis.member/left //runtime.left] + [synthesis.member/right //runtime.right]) + + (#synthesis.Alt leftP rightP) + (do phase.monad + [@alt-else generation.next + left! (path' phase (inc stack-depth) @alt-else @end leftP) + right! (path' phase stack-depth @else @end rightP)] + (wrap ($_ _.compose + _.dup + left! + (_.set-label @alt-else) + _.pop + right!))) + + (#synthesis.Seq leftP rightP) + (do phase.monad + [left! (path' phase stack-depth @else @end leftP) + right! (path' phase stack-depth @else @end rightP)] + (wrap ($_ _.compose + left! + right!))) + )) + +(def: (path phase path @end) + (-> Phase Path Label (Operation (Instruction Any))) + (do phase.monad + [@else generation.next + pathG (..path' phase 1 @else @end path)] + (wrap ($_ _.compose + pathG + (_.set-label @else) + _.pop + //runtime.pm-failure + _.aconst-null + (_.goto @end))))) + +(def: #export (if phase conditionS thenS elseS) + (-> Phase Synthesis Synthesis Synthesis (Operation (Instruction Any))) + (do phase.monad + [conditionG (phase conditionS) + thenG (phase thenS) + elseG (phase elseS)] + (wrap (do _.monad + [@else _.new-label + @end _.new-label] + ($_ _.compose + conditionG + (//value.unwrap type.boolean) + (_.ifeq @else) + thenG + (_.goto @end) + (_.set-label @else) + elseG + (_.set-label @end)))))) + +(def: #export (let phase inputS register bodyS) + (-> Phase Synthesis Register Synthesis (Operation (Instruction Any))) + (do phase.monad + [inputG (phase inputS) + bodyG (phase bodyS)] + (wrap ($_ _.compose + inputG + (_.astore (unsigned.u1 register)) + bodyG)))) + +(def: #export (case phase valueS path) + (-> Phase Synthesis Path (Operation (Instruction Any))) + (do phase.monad + [@end generation.next + valueG (phase valueS) + pathG (..path phase path @end)] + (wrap ($_ _.compose + _.aconst-null + valueG + //runtime.push + pathG + (_.set-label @end))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux new file mode 100644 index 000000000..5537715b0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux @@ -0,0 +1,89 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["." function]] + [data + ["." product] + [number + ["n" nat]] + [collection + ["." list ("#@." functor)]]] + [target + [jvm + ["_" instruction (#+ Label Instruction) ("#@." monad)] + [encoding + ["." unsigned]]]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." value] + [//// + [reference (#+ Register)] + ["." synthesis (#+ Path Synthesis)] + ["." phase + ["." generation]]]]) + +(def: (invariant? register changeS) + (-> Register Synthesis Bit) + (case changeS + (^ (synthesis.variable/local var)) + (n.= register var) + + _ + false)) + +(def: no-op + (_@wrap [])) + +(def: #export (recur translate updatesS) + (-> Phase (List Synthesis) (Operation (Instruction Any))) + (do phase.monad + [[@begin offset] generation.anchor + updatesG (|> updatesS + list.enumerate + (list@map (function (_ [index updateS]) + [(n.+ offset index) updateS])) + (monad.map @ (function (_ [register updateS]) + (if (invariant? register updateS) + (wrap [..no-op + ..no-op]) + (do @ + [fetchG (translate updateS) + #let [storeG (_.astore (unsigned.u1 register))]] + (wrap [fetchG storeG]))))))] + (wrap ($_ _.compose + ## It may look weird that first I fetch all the values separately, + ## and then I store them all. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't perform fetches + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## should be the case. + (|> updatesG + (list@map product.left) + (monad.seq _.monad)) + (|> updatesG + list.reverse + (list@map product.right) + (monad.seq _.monad)) + (_.goto @begin))))) + +(def: #export (scope translate [offset initsS+ iterationS]) + (-> Phase [Nat (List Synthesis) Synthesis] (Operation (Instruction Any))) + (do phase.monad + [@begin generation.next + initsI+ (monad.map @ translate initsS+) + iterationG (generation.with-anchor [@begin offset] + (translate iterationS)) + #let [initializationG (|> (list.enumerate initsI+) + (list@map (function (_ [index initG]) + ($_ _.compose + initG + (_.astore (unsigned.u1 (n.+ offset index)))))) + (monad.seq _.monad))]] + (wrap ($_ _.compose + initializationG + (_.set-label @begin) + iterationG)))) 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 05ef66973..078a136b7 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux @@ -1,17 +1,17 @@ (.module: - [lux (#- Definition) + [lux (#- Type Definition case) [data [binary (#+ Binary)]] [target [jvm ["_" instruction (#+ Label Instruction)] - [encoding - [name (#+ External)]] - ["." type - [category (#+ Value Return Method)]]]]] - ["." /// - [/// - [reference (#+ Register)]]] + ["." type (#+ Type) + ["." category (#+ Method)]]]]] + ["." // #_ + ["#." value] + ["/#" // + [/// + [reference (#+ Register)]]]] ) (type: #export Byte-Code Binary) @@ -35,12 +35,51 @@ (def: #export class (type.class "LuxRuntime" (list))) -(def: apply-failure-name - "apply_fail") +(def: #export $Tag type.int) +(def: #export $Flag //value.type) +(def: #export $Variant (type.array //value.type)) -(def: apply-failure-type +(def: #export $Offset type.int) +(def: #export $Tuple (type.array //value.type)) + +(def: #export $Stack (type.array //value.type)) + +(def: procedure + (-> Text (Type Method) (Instruction Any)) + (_.invokestatic ..class)) + +(def: failure-type (type.method [(list) type.void (list)])) (def: #export apply-failure - (Instruction Any) - (_.invokestatic ..class ..apply-failure-name ..apply-failure-type)) + (..procedure "apply_failure" ..failure-type)) + +(def: #export pm-failure + (..procedure "pm_failure" ..failure-type)) + +(def: push-name + "push") + +(def: push-type + (type.method [(list ..$Stack //value.type) ..$Stack (list)])) + +(def: #export push + (..procedure ..push-name ..push-type)) + +(def: case-name + "case") + +(def: case-type + (type.method [(list ..$Variant ..$Tag ..$Flag) //value.type (list)])) + +(def: #export case + (..procedure ..case-name ..case-type)) + +(def: projection-type + (type.method [(list ..$Tuple $Offset) //value.type (list)])) + +(def: #export left + (..procedure "left" ..projection-type)) + +(def: #export right + (..procedure "right" ..projection-type)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux index 52fcc390a..803ac2522 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux @@ -1,9 +1,50 @@ (.module: - [lux (#- type) + [lux (#- Type type) [target [jvm - ["." type]]]]) + ["_" instruction (#+ Instruction)] + ["." type (#+ Type) ("#@." equivalence) + [category (#+ Primitive)] + ["." box]]]]]) (def: #export field "value") (def: #export type (type.class "java.lang.Object" (list))) + +(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] + [(def: (<name> type) + (-> (Type Primitive) Text) + (`` (cond (~~ (template [<type> <output>] + [(type@= <type> type) <output>] + + [type.boolean <boolean>] + [type.byte <byte>] + [type.short <short>] + [type.int <int>] + [type.long <long>] + [type.float <float>] + [type.double <double>] + [type.char <char>])) + ## else + (undefined))))] + + [primitive-wrapper + box.boolean box.byte box.short box.int + box.long box.float box.double box.char] + [primitive-unwrap + "booleanValue" "byteValue" "shortValue" "intValue" + "longValue" "floatValue" "doubleValue" "charValue"] + ) + +(def: #export (wrap type) + (-> (Type Primitive) (Instruction Any)) + (let [wrapper (type.class (primitive-wrapper type) (list))] + (_.invokestatic wrapper "valueOf" + (type.method [(list type) wrapper (list)])))) + +(def: #export (unwrap type) + (-> (Type Primitive) (Instruction Any)) + (let [wrapper (type.class (primitive-wrapper type) (list))] + ($_ _.compose + (_.checkcast wrapper) + (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)]))))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 85b062009..0efa89571 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -2,8 +2,8 @@ [primitive (#+)] [structure (#+)] [reference (#+)] - ## [case (#+)] - ## [loop (#+)] + [case (#+)] + [loop (#+)] [function (#+)] ## [extension (#+)] )] |