aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/instruction.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm.lux24
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux275
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux89
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux65
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux45
-rw-r--r--stdlib/source/test/lux.lux4
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 (#+)]
)]