aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2019-10-16 20:55:03 -0400
committerEduardo Julian2019-10-16 20:55:03 -0400
commitde9d57c45da46cdae9e21ff1d9747952e0815b32 (patch)
treeb65b465b097fcd99484aa6baab30b2a7254834dc /stdlib/source
parent3028cc4f45d2d7d66456467de506341800df14d8 (diff)
Ported JVM function generation to the new JVM bytecode machinery.
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/target/jvm/encoding/name.lux2
-rw-r--r--stdlib/source/lux/target/jvm/field.lux12
-rw-r--r--stdlib/source/lux/target/jvm/instruction.lux70
-rw-r--r--stdlib/source/lux/target/jvm/method.lux14
-rw-r--r--stdlib/source/lux/target/jvm/type/parser.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux108
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/arity.lux11
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field.lux29
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux27
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux23
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/foreign.lux35
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux56
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/foreign.lux38
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial.lux (renamed from stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial.lux)28
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux (renamed from stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial/count.lux)13
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux142
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux24
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux96
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux66
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux49
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux7
-rw-r--r--stdlib/source/test/lux.lux2
-rw-r--r--stdlib/source/test/lux/target/jvm.lux76
29 files changed, 684 insertions, 366 deletions
diff --git a/stdlib/source/lux/target/jvm/encoding/name.lux b/stdlib/source/lux/target/jvm/encoding/name.lux
index 1ba56573a..cda98e0a0 100644
--- a/stdlib/source/lux/target/jvm/encoding/name.lux
+++ b/stdlib/source/lux/target/jvm/encoding/name.lux
@@ -17,7 +17,7 @@
Text
(def: #export internal
- (-> Text Internal)
+ (-> External Internal)
(|>> (text.replace-all ..external-separator
..internal-separator)
:abstraction))
diff --git a/stdlib/source/lux/target/jvm/field.lux b/stdlib/source/lux/target/jvm/field.lux
index 012f7b5ee..3f569502a 100644
--- a/stdlib/source/lux/target/jvm/field.lux
+++ b/stdlib/source/lux/target/jvm/field.lux
@@ -21,9 +21,9 @@
["#/." pool (#+ Pool)]]
["#." index (#+ Index)]
["#." attribute (#+ Attribute)]
- [type
- ["#." category (#+ Value)]
- ["#." descriptor (#+ Descriptor)]]])
+ ["#." type (#+ Type)
+ [category (#+ Value)]
+ [descriptor (#+ Descriptor)]]])
(type: #export #rec Field
{#modifier (Modifier Field)
@@ -63,12 +63,12 @@
[(binaryF.row/16 //attribute.writer) #attributes]))
)))
-(def: #export (field modifier name descriptor attributes)
- (-> (Modifier Field) UTF8 (Descriptor Value) (Row Attribute)
+(def: #export (field modifier name type attributes)
+ (-> (Modifier Field) UTF8 (Type Value) (Row Attribute)
(State Pool Field))
(do state.monad
[@name (//constant/pool.utf8 name)
- @descriptor (//constant/pool.descriptor descriptor)]
+ @descriptor (//constant/pool.descriptor (//type.descriptor type))]
(wrap {#modifier modifier
#name @name
#descriptor @descriptor
diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux
index 95e2b9a05..10fce7368 100644
--- a/stdlib/source/lux/target/jvm/instruction.lux
+++ b/stdlib/source/lux/target/jvm/instruction.lux
@@ -27,14 +27,20 @@
["/#" // #_
["#." index]
[encoding
- ["#." name (#+ External)]
+ ["#." name]
["#." unsigned (#+ U1 U2)]
["#." signed (#+ S4)]]
["#." constant (#+ UTF8)
- ["#/."pool (#+ Pool)]]
+ ["#/." pool (#+ Pool)]]
["." type (#+ Type)
- [category (#+ Value Return)]
- ["." descriptor (#+ Descriptor)]]]])
+ [category (#+ Value' Value Return' Return Method Class)]
+ ["." reflection]
+ ["." parser]]]])
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
(type: #export Label Nat)
@@ -92,6 +98,7 @@
(def: #export (set-label label)
(-> Label (Instruction Any))
+ ## TODO: Throw an exception if trying to set an already-set label!
(function (_ [pool tracker])
[[pool
(update@ #known-labels
@@ -506,10 +513,10 @@
(template [<name> <bytecode>]
[(def: #export (<name> class)
- (-> External (Instruction Any))
+ (-> (Type Class) (Instruction Any))
(do ..monad
## TODO: Make sure it"s impossible to have indexes greater than U2.
- [index (..lift (//constant/pool.class (//name.internal class)))]
+ [index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
(..nullary (<bytecode> index))))]
[new /bytecode.new]
@@ -523,38 +530,39 @@
(..nullary (/bytecode.iinc register increase)))
(def: #export (multianewarray class count)
- (-> External U1 (Instruction Any))
+ (-> (Type Class) U1 (Instruction Any))
(do ..monad
- [index (..lift (//constant/pool.class (//name.internal class)))]
+ [index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
(..nullary (/bytecode.multianewarray index count))))
-(def: (descriptor-size descriptor)
- (-> (Descriptor Return) U1)
+(def: (type-size type)
+ (-> (Type Return) U1)
(//unsigned.u1
- (cond (is? descriptor.void descriptor)
+ (cond (is? type.void type)
0
- (or (is? descriptor.long descriptor)
- (is? descriptor.double descriptor))
+ (or (is? type.long type)
+ (is? type.double type))
2
## else
1)))
(template [<static?> <name> <bytecode>]
- [(def: #export (<name> class method [inputs output])
- (-> External Text [(List (Descriptor Value)) (Descriptor Return)] (Instruction Any))
- (do ..monad
- [index (<| ..lift
- (//constant/pool.method class)
- {#//constant/pool.name method
- #//constant/pool.descriptor (descriptor.method [inputs output])})]
- (..nullary (<bytecode>
- index
- (|> inputs
- (list@map descriptor-size)
- (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
- (descriptor-size output)))))]
+ [(def: #export (<name> class method type)
+ (-> (Type Class) Text (Type Method) (Instruction Any))
+ (let [[inputs output exceptions] (parser.method type)]
+ (do ..monad
+ [index (<| ..lift
+ (//constant/pool.method (..reflection class))
+ {#//constant/pool.name method
+ #//constant/pool.descriptor (type.descriptor type)})]
+ (..nullary (<bytecode>
+ index
+ (|> inputs
+ (list@map ..type-size)
+ (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
+ (..type-size output))))))]
[#1 invokestatic /bytecode.invokestatic]
[#0 invokevirtual /bytecode.invokevirtual]
@@ -564,16 +572,16 @@
(template [<name> <1> <2>]
[(def: #export (<name> class field type)
- (-> External Text (Descriptor Value) (Instruction Any))
+ (-> (Type Class) Text (Type Value) (Instruction Any))
(do ..monad
[index (<| ..lift
- (//constant/pool.field class)
+ (//constant/pool.field (..reflection class))
{#//constant/pool.name field
- #//constant/pool.descriptor type})]
- (..nullary (cond (is? descriptor.long type)
+ #//constant/pool.descriptor (type.descriptor type)})]
+ (..nullary (cond (is? type.long type)
(<2> index)
- (is? descriptor.double type)
+ (is? type.double type)
(<2> index)
## else
diff --git a/stdlib/source/lux/target/jvm/method.lux b/stdlib/source/lux/target/jvm/method.lux
index 0c9de952a..cb7324316 100644
--- a/stdlib/source/lux/target/jvm/method.lux
+++ b/stdlib/source/lux/target/jvm/method.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- static)
+ [lux (#- Type static)
[abstract
[monoid (#+)]
["." equivalence (#+ Equivalence)]
@@ -26,14 +26,14 @@
["#." instruction (#+ Instruction)
["#/." condition]
["#/." bytecode]]
- [type
- ["#." category]
+ ["#." type (#+ Type)
+ ["#/." category]
["#." descriptor (#+ Descriptor)]]])
(type: #export #rec Method
{#modifier (Modifier Method)
#name (Index UTF8)
- #descriptor (Index (Descriptor //category.Method))
+ #descriptor (Index (Descriptor //type/category.Method))
#attributes (Row Attribute)})
(modifiers: Method
@@ -51,12 +51,12 @@
["1000" synthetic]
)
-(def: #export (method modifier name descriptor attributes code)
- (-> (Modifier Method) UTF8 (Descriptor //category.Method) (List (State Pool Attribute)) (Instruction Any)
+(def: #export (method modifier name type attributes code)
+ (-> (Modifier Method) UTF8 (Type //type/category.Method) (List (State Pool Attribute)) (Instruction Any)
(State Pool Method))
(do state.monad
[@name (//constant/pool.utf8 name)
- @descriptor (//constant/pool.descriptor descriptor)
+ @descriptor (//constant/pool.descriptor (//type.descriptor type))
attributes (monad.seq @ attributes)
?code (//instruction.resolve code)
[environment bytecode] (case (do try.monad
diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux
index 298364357..049d53f45 100644
--- a/stdlib/source/lux/target/jvm/type/parser.lux
+++ b/stdlib/source/lux/target/jvm/type/parser.lux
@@ -190,25 +190,33 @@
..class
..array))
+(def: inputs
+ (|> (<>.some ..value)
+ (<>.after (<t>.this //signature.arguments-start))
+ (<>.before (<t>.this //signature.arguments-end))))
+
(def: #export return
(Parser (Type Return))
(<>.either ..void
..value))
+(def: exception
+ (Parser (Type Class))
+ (|> (..class' ..parameter)
+ (<>.after (<t>.this //signature.exception-prefix))))
+
(def: #export method
- (Parser (Type Method))
- (let [parameters (: (Parser (List (Type Value)))
- (|> (<>.some ..value)
- (<>.after (<t>.this //signature.arguments-start))
- (<>.before (<t>.this //signature.arguments-end))))
- exception (: (Parser (Type Class))
- (|> (..class' ..parameter)
- (<>.after (<t>.this //signature.exception-prefix))))]
- (do <>.monad
- [parameters parameters
- return ..return
- exceptions (<>.some exception)]
- (wrap (//.method [parameters return exceptions])))))
+ (-> (Type Method)
+ [(List (Type Value)) (Type Return) (List (Type Class))])
+ (let [parser (do <>.monad
+ [inputs ..inputs
+ return ..return
+ exceptions (<>.some ..exception)]
+ (wrap [inputs return exceptions]))]
+ (|>> //.signature
+ //signature.signature
+ (<t>.run parser)
+ try.assume)))
(template [<name> <category> <parser>]
[(def: #export <name>
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
index b67ddcbcd..97db2b34c 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
@@ -7,7 +7,7 @@
["#." primitive]
["#." structure]
["#." reference]
- ## ["#." function]
+ ["#." function]
## ["#." case]
## ["#." loop]
["//#" ///
@@ -57,11 +57,11 @@
## (^ (synthesis.loop/recur updates))
## (/loop.recur generate updates)
- ## (^ (synthesis.function/abstraction abstraction))
- ## (/function.abstraction generate abstraction)
+ (^ (synthesis.function/abstraction abstraction))
+ (/function.abstraction generate abstraction)
- ## (^ (synthesis.function/apply application))
- ## (/function.apply generate application)
+ (^ (synthesis.function/apply application))
+ (/function.apply generate application)
## (#synthesis.Extension extension)
## (/extension.apply generate extension)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
index 36f8d72c6..a6a89993e 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #*
+ [lux (#- Type)
[abstract
["." monad (#+ do)]]
[control
@@ -10,54 +10,120 @@
["n" nat]]
[collection
["." list ("#@." monoid functor)]
- ["." row]]]
+ ["." row]]
+ [format
+ [".F" binary]]]
[target
[jvm
+ ["." version]
["." modifier (#+ Modifier) ("#@." monoid)]
["." field (#+ Field)]
["." method (#+ Method)]
["_" instruction (#+ Label Instruction) ("#@." monad)]
+ ["." class (#+ Class)]
+ ["." type (#+ Type)
+ [category (#+ Return' Value')]
+ ["." reflection]]
["." constant
[pool (#+ Pool)]]
[encoding
- [name (#+ External)]
+ ["." name (#+ External Internal)]
["." unsigned]]]]]
["." / #_
["#." abstract]
- ["#." arity]
- ["#." field
- ["#/." foreign]
- ["#/." partial
- ["#/." count]]]
- ["#." method #_
- ["#/." new]
- ["#/." reset]
- ["#/." implementation]
- ["#/." apply]]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
+ [method
+ ["#." init]
+ ["#." new]
+ ["#." implementation]
+ ["#." reset]
+ ["#." apply]]
["/#" // #_
[runtime (#+ Operation Phase)]
- ["#." value]
- ["#." reference]
[////
[reference (#+ Register)]
[analysis (#+ Environment)]
[synthesis (#+ Synthesis Abstraction Apply)]
["." arity (#+ Arity)]
- ["." phase]]]])
+ ["." phase
+ ["." generation]]]]])
-(def: #export (apply generate [abstractionS argsS])
+(def: #export (with @begin class environment arity body)
+ (-> Label External Environment Arity (Instruction Any)
+ (Operation [(List (State Pool Field))
+ (List (State Pool Method))
+ (Instruction Any)]))
+ (let [classT (type.class class (list))
+ fields (: (List (State Pool Field))
+ (list& /arity.constant
+ (list@compose (/foreign.variables environment)
+ (/partial.variables arity))))
+ methods (: (List (State Pool Method))
+ (list& (/init.method classT environment arity)
+ (/reset.method classT environment arity)
+ (if (arity.multiary? arity)
+ (|> (n.min arity /arity.maximum)
+ list.indices
+ (list@map (|>> inc (/apply.method classT environment arity @begin body)))
+ (list& (/implementation.method arity @begin body)))
+ (list (/implementation.method' /apply.name arity @begin body)))))]
+ (do phase.monad
+ [instance (/new.instance classT environment arity)]
+ (wrap [fields methods instance]))))
+
+(def: modifier
+ (Modifier Class)
+ ($_ modifier@compose
+ class.public
+ class.final))
+
+(def: this-offset 1)
+
+(def: internal
+ (All [category]
+ (-> (Type (<| Return' Value' category))
+ Internal))
+ (|>> type.reflection reflection.reflection name.internal))
+
+(def: #export (abstraction generate [environment arity bodyS])
+ (-> Phase Abstraction (Operation (Instruction Any)))
+ (do phase.monad
+ [@begin generation.next
+ [function-class bodyG] (generation.with-context
+ (generation.with-anchor [@begin ..this-offset]
+ (generate bodyS)))
+ [fields methods instance] (..with @begin function-class environment arity bodyG)
+ _ (generation.save! true ["" function-class]
+ [function-class
+ (<| (binaryF.run class.writer)
+ (class.class version.v6_0
+ ..modifier
+ (name.internal function-class)
+ (..internal /abstract.class) (list)
+ fields
+ methods
+ (row.row)))])]
+ (wrap instance)))
+
+(def: #export (apply generate [abstractionS inputsS])
(-> Phase Apply (Operation (Instruction Any)))
(do phase.monad
[abstractionG (generate abstractionS)
- argsG (monad.map @ generate argsS)]
+ inputsG (monad.map @ generate inputsS)]
(wrap ($_ _.compose
abstractionG
- (|> argsG
+ (|> inputsG
(list.split-all /arity.maximum)
(monad.map _.monad
(function (_ batchG)
($_ _.compose
(_.checkcast /abstract.class)
(monad.seq _.monad batchG)
- (_.invokevirtual /abstract.class /method/apply.name (/method/apply.type (list.size batchG)))
- ))))))))
+ (_.invokevirtual /abstract.class /apply.name (/apply.type (list.size batchG)))
+ ))))
+ ))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
index 79cede3a4..9b653ec6c 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/abstract.lux
@@ -1,4 +1,7 @@
(.module:
- [lux #*])
+ [lux #*
+ [target
+ [jvm
+ ["." type]]]])
-(def: #export class "LuxFunction")
+(def: #export class (type.class "LuxFunction" (list)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/arity.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/arity.lux
deleted file mode 100644
index ac35be9ba..000000000
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/arity.lux
+++ /dev/null
@@ -1,11 +0,0 @@
-(.module:
- [lux (#- type)
- [target
- [jvm
- [type
- ["." descriptor]]]]])
-
-(def: #export field "arity")
-(def: #export type descriptor.int)
-(def: #export minimum 1)
-(def: #export maximum 8)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field.lux
deleted file mode 100644
index 849d9a663..000000000
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field.lux
+++ /dev/null
@@ -1,29 +0,0 @@
-(.module:
- [lux (#- type)
- [target
- [jvm
- ["." modifier (#+ Modifier) ("#@." monoid)]
- ["." field (#+ Field)]
- ["_" instruction (#+ Instruction)]
- [encoding
- [name (#+ External)]]]]]
- ["." /// #_
- [runtime (#+ Operation)]
- ["#." value]
- ["#." reference]])
-
-(def: #export type ///value.type)
-
-(def: #export (field class name)
- (-> External Text (Instruction Any))
- ($_ _.compose
- ///reference.this
- (_.getfield class name ..type)
- ))
-
-(def: #export modifier
- (Modifier Field)
- ($_ modifier@compose
- field.private
- field.final
- ))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux
new file mode 100644
index 000000000..456e46b86
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant.lux
@@ -0,0 +1,27 @@
+(.module:
+ [lux (#- Type type)
+ [control
+ [state (#+ State)]]
+ [data
+ [collection
+ ["." row]]]
+ [target
+ [jvm
+ ["." field (#+ Field)]
+ ["." modifier (#+ Modifier) ("#@." monoid)]
+ [type (#+ Type)
+ [category (#+ Value)]]
+ [constant
+ [pool (#+ Pool)]]]]])
+
+(def: modifier
+ (Modifier Field)
+ ($_ modifier@compose
+ field.public
+ field.static
+ field.final
+ ))
+
+(def: #export (constant name type)
+ (-> Text (Type Value) (State Pool Field))
+ (field.field ..modifier name type (row.row)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux
new file mode 100644
index 000000000..589d9c43d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/constant/arity.lux
@@ -0,0 +1,23 @@
+(.module:
+ [lux (#- type)
+ [control
+ [state (#+ State)]]
+ [target
+ [jvm
+ ["." type]
+ ["." field (#+ Field)]
+ [constant
+ [pool (#+ Pool)]]]]]
+ ["." //
+ [///////
+ [arity (#+ Arity)]]])
+
+(def: #export name "arity")
+(def: #export type type.int)
+
+(def: #export minimum Arity 1)
+(def: #export maximum Arity 8)
+
+(def: #export constant
+ (State Pool Field)
+ (//.constant ..name ..type))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/foreign.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/foreign.lux
deleted file mode 100644
index 1534a9683..000000000
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/foreign.lux
+++ /dev/null
@@ -1,35 +0,0 @@
-(.module:
- [lux (#- Type)
- [control
- [state (#+ State)]]
- [data
- [collection
- ["." list ("#@." functor)]
- ["." row]]]
- [target
- [jvm
- ["." field (#+ Field)]
- [constant
- [pool (#+ Pool)]]
- [type
- [category (#+ Value)]
- [descriptor (#+ Descriptor)]]]]]
- ["." //
- ["//#" /// #_
- ["#." value]
- ["#." reference]
- [////
- [analysis (#+ Environment)]]]])
-
-(def: #export (closure environment)
- (-> Environment (List (Descriptor Value)))
- (list.repeat (list.size environment) ////value.type))
-
-(def: #export fields
- (-> Environment (List (State Pool Field)))
- (|>> list.enumerate
- (list@map (function (_ [index source])
- (field.field //.modifier
- (////reference.foreign-name index)
- //.type
- (row.row))))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
new file mode 100644
index 000000000..083d279ea
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable.lux
@@ -0,0 +1,56 @@
+(.module:
+ [lux (#- Type type)
+ [control
+ [state (#+ State)]]
+ [data
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]]
+ [target
+ [jvm
+ ["." modifier (#+ Modifier) ("#@." monoid)]
+ ["." field (#+ Field)]
+ ["_" instruction (#+ Instruction)]
+ [type (#+ Type)
+ [category (#+ Value Class)]]
+ [constant
+ [pool (#+ Pool)]]]]]
+ ["." //// #_
+ ["#." value]
+ ["#." reference]
+ [////
+ [reference (#+ Register)]]])
+
+(def: #export type ////value.type)
+
+(def: #export (get class name)
+ (-> (Type Class) Text (Instruction Any))
+ ($_ _.compose
+ ////reference.this
+ (_.getfield class name ..type)
+ ))
+
+(def: #export (put naming class register value)
+ (-> (-> Register Text) (Type Class) Register (Instruction Any) (Instruction Any))
+ ($_ _.compose
+ ////reference.this
+ value
+ (_.putfield class (naming register) ..type)))
+
+(def: modifier
+ (Modifier Field)
+ ($_ modifier@compose
+ field.private
+ field.final
+ ))
+
+(def: #export (variable name type)
+ (-> Text (Type Value) (State Pool Field))
+ (field.field ..modifier name type (row.row)))
+
+(def: #export (variables naming amount)
+ (-> (-> Register Text) Nat (List (State Pool Field)))
+ (|> amount
+ list.indices
+ (list@map (function (_ register)
+ (..variable (naming register) ..type)))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/foreign.lux
new file mode 100644
index 000000000..0b4a2bc3d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/foreign.lux
@@ -0,0 +1,38 @@
+(.module:
+ [lux (#- Type)
+ [control
+ [state (#+ State)]]
+ [data
+ [collection
+ ["." list ("#@." functor)]
+ ["." row]]]
+ [target
+ [jvm
+ ["_" instruction (#+ Instruction)]
+ ["." field (#+ Field)]
+ [constant
+ [pool (#+ Pool)]]
+ [type (#+ Type)
+ [category (#+ Value Class)]]]]]
+ ["." //
+ ["///#" //// #_
+ ["#." reference]
+ [////
+ [reference (#+ Register)]
+ [analysis (#+ Environment)]]]])
+
+(def: #export (closure environment)
+ (-> Environment (List (Type Value)))
+ (list.repeat (list.size environment) //.type))
+
+(def: #export (get class register)
+ (-> (Type Class) Register (Instruction Any))
+ (//.get class (/////reference.foreign-name register)))
+
+(def: #export (put class register value)
+ (-> (Type Class) Register (Instruction Any) (Instruction Any))
+ (//.put /////reference.foreign-name class register value))
+
+(def: #export variables
+ (-> Environment (List (State Pool Field)))
+ (|>> list.size (//.variables /////reference.foreign-name)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial.lux
index 0f3c9ced5..39be26183 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #*
+ [lux (#- Type)
[abstract
["." monad]]
[control
@@ -14,16 +14,20 @@
[jvm
["." field (#+ Field)]
["_" instruction (#+ Label Instruction) ("#@." monad)]
+ [type (#+ Type)
+ [category (#+ Class)]]
[constant
[pool (#+ Pool)]]]]]
["." / #_
["#." count]
["/#" //
["/#" // #_
- ["#." arity]
- ["/#" // #_
+ [constant
+ ["#." arity]]
+ ["//#" /// #_
["#." reference]
[////
+ [reference (#+ Register)]
["." arity (#+ Arity)]]]]]])
(def: #export (initial amount)
@@ -34,15 +38,17 @@
(monad.seq _.monad))
(_@wrap [])))
-(def: #export fields
+(def: #export (get class register)
+ (-> (Type Class) Register (Instruction Any))
+ (//.get class (/////reference.partial-name register)))
+
+(def: #export (put class register value)
+ (-> (Type Class) Register (Instruction Any) (Instruction Any))
+ (//.put /////reference.partial-name class register value))
+
+(def: #export variables
(-> Arity (List (State Pool Field)))
- (|>> (n.- ///arity.minimum)
- list.indices
- (list@map (function (_ index)
- (field.field //.modifier
- (////reference.partial-name index)
- //.type
- (row.row))))))
+ (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name)))
(def: #export (new arity)
(-> Arity (Instruction Any))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial/count.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux
index 9b611fb94..b646ddbf6 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/partial/count.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/field/variable/partial/count.lux
@@ -2,19 +2,18 @@
[lux (#- type)
[target
[jvm
- ["_" instruction (#+ Instruction) ("#@." monad)]
+ ["_" instruction (#+ Instruction)]
[encoding
[name (#+ External)]
["." unsigned]]
- [type
- ["." descriptor]]]]]
- ["." //// #_
+ ["." type]]]]
+ ["." ///// #_
["#." abstract]
["/#" // #_
["#." reference]]])
(def: #export field "partials")
-(def: #export type descriptor.int)
+(def: #export type type.int)
(def: #export initial
(Instruction Any)
@@ -23,6 +22,6 @@
(def: #export value
(Instruction Any)
($_ _.compose
- /////reference.this
- (_.getfield ////abstract.class ..field ..type)
+ //////reference.this
+ (_.getfield /////abstract.class ..field ..type)
))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
index e298ab187..0d4e1f2b3 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/apply.lux
@@ -1,37 +1,56 @@
(.module:
- [lux (#- type)
+ [lux (#- Type type)
[abstract
- ["." monad]]
+ ["." monad (#+ do)]]
+ [control
+ [state (#+ State)]]
[data
[number
["n" nat]
+ ["i" int]
["." i32]]
[collection
- ["." list]]]
+ ["." list ("#@." monoid functor)]]]
[target
[jvm
- ["_" instruction (#+ Instruction) ("#@." monad)]
- ["." constant]
+ ["_" instruction (#+ Label Instruction) ("#@." monad)]
+ ["." method (#+ Method)]
+ ["." constant
+ [pool (#+ Pool)]]
[encoding
- ["." unsigned]]
- [type
- ["." category (#+ Value Return)]
- ["." descriptor (#+ Descriptor)]]]]]
- ["." /// #_
- ["#." abstract]
- ["#." arity]
+ ["." unsigned]
+ ["." signed]]
+ ["." type (#+ Type)
+ ["." category (#+ Class)]]]]]
+ ["." //
+ ["#." reset]
+ ["#." implementation]
+ ["#." init]
["/#" // #_
- ["#." value]
- [////
- [reference (#+ Register)]
- [arity (#+ Arity)]]]])
+ ["#." abstract]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." partial
+ ["#/." count]]
+ ["#." foreign]]]
+ ["/#" // #_
+ ["#." runtime]
+ ["#." value]
+ ["#." reference]
+ [////
+ [analysis (#+ Environment)]
+ [arity (#+ Arity)]
+ ["." reference (#+ Register)]]]]])
(def: #export name "apply")
(def: #export (type arity)
- (-> Arity [(List (Descriptor Value)) (Descriptor Return)])
- [(list.repeat arity ////value.type)
- ////value.type])
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity ////value.type)
+ ////value.type
+ (list)]))
(def: (increment by)
(-> Nat (Instruction Any))
@@ -48,7 +67,7 @@
(_@wrap [])
))
-(def: #export (instruction offset amount)
+(def: (apply offset amount)
(-> Register Nat (Instruction Any))
(let [arity (n.min amount ///arity.maximum)]
($_ _.compose
@@ -56,7 +75,86 @@
(..inputs offset arity)
(_.invokevirtual ///abstract.class ..name (..type arity))
(if (n.> ///arity.maximum amount)
- (instruction (n.+ ///arity.maximum offset)
- (n.- ///arity.maximum amount))
+ (apply (n.+ ///arity.maximum offset)
+ (n.- ///arity.maximum amount))
(_@wrap []))
)))
+
+(def: this-offset 1)
+
+(def: #export (method class environment function-arity @begin body apply-arity)
+ (-> (Type Class) Environment Arity Label (Instruction Any) Arity (State Pool Method))
+ (let [num-partials (dec function-arity)
+ over-extent (i.- (.int apply-arity)
+ (.int function-arity))
+ failure ($_ _.compose
+ ////runtime.apply-failure
+ _.aconst-null
+ _.areturn)]
+ (method.method //.modifier ..name
+ (..type apply-arity)
+ (list)
+ (do _.monad
+ [@default _.new-label
+ @labels (|> _.new-label
+ (list.repeat num-partials)
+ (monad.seq _.monad))
+ #let [cases (|> (list@compose @labels (list @default))
+ list.enumerate
+ (list@map (function (_ [stage @case])
+ (let [current-partials (|> (list.indices stage)
+ (list@map (///partial.get class))
+ (monad.seq _.monad))
+ already-partial? (n.> 0 stage)
+ exact-match? (i.= over-extent (.int stage))
+ has-more-than-necessary? (i.> over-extent (.int stage))]
+ (cond exact-match?
+ ($_ _.compose
+ (_.set-label @case)
+ ////reference.this
+ (if already-partial?
+ (_.invokevirtual class //reset.name (//reset.type class))
+ (_@wrap []))
+ current-partials
+ (inputs ..this-offset apply-arity)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ _.areturn)
+
+ has-more-than-necessary?
+ (let [inputs-to-completion (|> function-arity (n.- stage))
+ inputs-left (|> apply-arity (n.- inputs-to-completion))]
+ ($_ _.compose
+ (_.set-label @case)
+ ////reference.this
+ (_.invokevirtual class //reset.name (//reset.type class))
+ current-partials
+ (inputs ..this-offset inputs-to-completion)
+ (_.invokevirtual class //implementation.name (//implementation.type function-arity))
+ (apply (n.+ ..this-offset inputs-to-completion) inputs-left)
+ _.areturn))
+
+ ## (i.< over-extent (.int stage))
+ (let [current-environment (|> (list.indices (list.size environment))
+ (list@map (///foreign.get class))
+ (monad.seq _.monad))
+ missing-partials (|> _.aconst-null
+ (list.repeat (|> num-partials (n.- apply-arity) (n.- stage)))
+ (monad.seq _.monad))]
+ ($_ _.compose
+ (_.set-label @case)
+ (_.new class)
+ _.dup
+ current-environment
+ ///partial/count.value
+ (..increment apply-arity)
+ current-partials
+ (inputs ..this-offset apply-arity)
+ missing-partials
+ (_.invokevirtual class //init.name (//init.type environment function-arity))
+ _.areturn))))))
+ (monad.seq _.monad))]]
+ ($_ _.compose
+ ///partial/count.value
+ (_.tableswitch (signed.s4 +0) @default @labels)
+ cases
+ failure)))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
index 18df43d9d..8643dc916 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/implementation.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- type)
+ [lux (#- Type type)
[control
[state (#+ State)]]
[data
@@ -11,9 +11,8 @@
["_" instruction (#+ Label Instruction)]
[constant
[pool (#+ Pool)]]
- [type
- ["." category]
- ["." descriptor (#+ Descriptor)]]]]]
+ ["." type (#+ Type)
+ ["." category]]]]]
["." //
["//#" /// #_
["#." value]
@@ -23,13 +22,14 @@
(def: #export name "impl")
(def: #export (type arity)
- (-> Arity (Descriptor category.Method))
- (descriptor.method [(list.repeat arity ////value.type)
- ////value.type]))
+ (-> Arity (Type category.Method))
+ (type.method [(list.repeat arity ////value.type)
+ ////value.type
+ (list)]))
-(def: #export (method arity @begin body)
- (-> Arity Label (Instruction Any) (State Pool Method))
- (method.method //.modifier ..name
+(def: #export (method' name arity @begin body)
+ (-> Text Arity Label (Instruction Any) (State Pool Method))
+ (method.method //.modifier name
(..type arity)
(list)
($_ _.compose
@@ -37,3 +37,7 @@
body
_.areturn
)))
+
+(def: #export method
+ (-> Arity Label (Instruction Any) (State Pool Method))
+ (method' ..name))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
index 5f771abcd..5eddafb8a 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/init.lux
@@ -1,30 +1,96 @@
(.module:
- [lux (#- type)
+ [lux (#- Type type)
+ [abstract
+ ["." monad]]
+ [control
+ [state (#+ State)]]
+ [data
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#@." monoid functor)]]]
[target
[jvm
["_" instruction (#+ Instruction)]
+ ["." method (#+ Method)]
[encoding
["." unsigned]]
- [type
- ["." category (#+ Value Return)]
- ["." descriptor (#+ Descriptor)]]]]]
- ["." /// #_
- ["#." abstract]
- ["#." arity]
+ [constant
+ [pool (#+ Pool)]]
+ ["." type (#+ Type)
+ ["." category (#+ Class Value)]]]]]
+ ["." //
+ ["#." implementation]
["/#" // #_
- [////
- ["." arity (#+ Arity)]]]])
+ ["#." abstract]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
+ ["/#" // #_
+ ["#." value]
+ ["#." reference]
+ [////
+ [reference (#+ Register)]
+ [analysis (#+ Environment)]
+ ["." arity (#+ Arity)]]]]])
-(def: #export type
- [(List (Descriptor Value))
- (Descriptor Return)]
- [(list ///arity.type) descriptor.void])
+(def: #export name "<init>")
-(def: #export (instruction environment-size arity)
+(def: (partials arity)
+ (-> Arity (List (Type Value)))
+ (list.repeat arity ////value.type))
+
+(def: #export (type environment arity)
+ (-> Environment Arity (Type category.Method))
+ (type.method [(list@compose (///foreign.closure environment)
+ (if (arity.multiary? arity)
+ (list& ///arity.type (..partials arity))
+ (list)))
+ type.void
+ (list)]))
+
+(def: super-type
+ (Type category.Method)
+ (type.method [(list ///arity.type) type.void (list)]))
+
+(def: #export (super environment-size arity)
(-> Nat Arity (Instruction Any))
(let [arity-register (inc environment-size)]
($_ _.compose
(if (arity.unary? arity)
(_.bipush (unsigned.u1 0))
(_.iload (unsigned.u1 arity-register)))
- (_.invokespecial ///abstract.class "<init>" ..type))))
+ (_.invokespecial ///abstract.class ..name ..super-type))))
+
+(def: (store-all amount put offset)
+ (-> Nat
+ (-> Register (Instruction Any) (Instruction Any))
+ (-> Register Register)
+ (Instruction Any))
+ (|> (list.indices amount)
+ (list@map (function (_ register)
+ (put register
+ (_.aload (unsigned.u1 (offset register))))))
+ (monad.seq _.monad)))
+
+(def: #export (method class environment arity)
+ (-> (Type Class) Environment Arity (State Pool Method))
+ (let [environment-size (list.size environment)
+ offset-foreign (: (-> Register Register)
+ (n.+ 1))
+ offset-arity (: (-> Register Register)
+ (|>> offset-foreign (n.+ environment-size)))
+ offset-partial (: (-> Register Register)
+ (|>> offset-arity (n.+ 1)))]
+ (method.method //.modifier ..name
+ (..type environment arity)
+ (list)
+ ($_ _.compose
+ ////reference.this
+ (..super environment-size arity)
+ (store-all environment-size (///foreign.put class) offset-foreign)
+ (store-all (dec arity) (///partial.put class) offset-partial)
+ _.return))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux
index f03d333b2..241ec2676 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/new.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- type)
+ [lux (#- Type type)
[abstract
["." monad (#+ do)]]
[control
@@ -18,18 +18,19 @@
["." constant
[pool (#+ Pool)]]
[encoding
- [name (#+ External)]
["." unsigned]]
- [type
- ["." category (#+ Value Return)]
- ["." descriptor (#+ Descriptor)]]]]]
+ [type (#+ Type)
+ ["." category (#+ Class Value Return)]]]]]
["." //
["#." init]
+ ["#." implementation]
["/#" // #_
- ["#." arity]
- ["#." field
- ["#/." foreign]
- ["#/." partial]]
+ [field
+ [constant
+ ["#." arity]]
+ [variable
+ ["#." foreign]
+ ["#." partial]]]
["/#" // #_
[runtime (#+ Operation)]
["#." value]
@@ -39,32 +40,23 @@
["." arity (#+ Arity)]
["." phase]]]]])
-(def: (arguments arity)
- (-> Arity (List (Descriptor Value)))
- (list.repeat (dec arity) ////value.type))
-
-(def: #export (type environment arity)
- (-> Environment Arity [(List (Descriptor Value))
- (Descriptor Return)])
- [(list@compose (///field/foreign.closure environment)
- (if (arity.multiary? arity)
- (list& ///arity.type (arguments arity))
- (list)))
- descriptor.void])
+(def: #export (instance' foreign-setup class environment arity)
+ (-> (List (Instruction Any)) (Type Class) Environment Arity (Instruction Any))
+ ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.seq _.monad foreign-setup)
+ (///partial.new arity)
+ (_.invokespecial class //init.name (//init.type environment arity))))
(def: #export (instance class environment arity)
- (-> External Environment Arity (Operation (Instruction Any)))
+ (-> (Type Class) Environment Arity (Operation (Instruction Any)))
(do phase.monad
[foreign* (monad.map @ ////reference.variable environment)]
- (wrap ($_ _.compose
- (_.new class)
- _.dup
- (monad.seq _.monad foreign*)
- (///field/partial.new arity)
- (_.invokespecial class "<init>" (..type environment arity))))))
+ (wrap (instance' foreign* class environment arity))))
(def: #export (method class environment arity)
- (-> External Environment Arity (State Pool Method))
+ (-> (Type Class) Environment Arity (State Pool Method))
(let [after-this (: (-> Nat Nat)
(n.+ 1))
environment-size (list.size environment)
@@ -72,22 +64,16 @@
(|>> after-this (n.+ environment-size)))
after-arity (: (-> Nat Nat)
(|>> after-environment (n.+ 1)))]
- (method.method //.modifier "<init>"
- (descriptor.method (..type environment arity))
+ (method.method //.modifier //init.name
+ (//init.type environment arity)
(list)
($_ _.compose
////reference.this
- (//init.instruction environment-size arity)
+ (//init.super environment-size arity)
(monad.map _.monad (function (_ register)
- ($_ _.compose
- ////reference.this
- (_.aload (unsigned.u1 (after-this register)))
- (_.putfield class (////reference.foreign-name register) ////value.type)))
+ (///foreign.put class register (_.aload (unsigned.u1 (after-this register)))))
(list.indices environment-size))
(monad.map _.monad (function (_ register)
- ($_ _.compose
- ////reference.this
- (_.aload (unsigned.u1 (after-arity register)))
- (_.putfield class (////reference.partial-name register) ////value.type)))
+ (///partial.put class register (_.aload (unsigned.u1 (after-arity register)))))
(list.indices (n.- ///arity.minimum arity)))
_.areturn))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux
index e43fd1b9b..2eab6933b 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/function/method/reset.lux
@@ -1,60 +1,49 @@
(.module:
- [lux (#- type)
- [abstract
- ["." monad]]
+ [lux (#- Type type)
[control
[state (#+ State)]]
[data
[collection
- ["." list]]]
+ ["." list ("#@." functor)]]]
[target
[jvm
- [modifier (#+ Modifier)]
["." method (#+ Method)]
- ["_" instruction]
+ ["_" instruction (#+ Instruction)]
[constant
[pool (#+ Pool)]]
- [encoding
- [name (#+ External)]]
- [type
- ["." category]
- ["." descriptor (#+ Descriptor)]]]]]
+ ["." type (#+ Type)
+ ["." category (#+ Class)]]]]]
["." //
["#." new]
["/#" // #_
- ["#." arity]
- ["#." field
- ["#/." partial]]
+ [field
+ [variable
+ ["#." foreign]]]
["/#" // #_
- ["#." value]
["#." reference]
[////
[analysis (#+ Environment)]
- [reference (#+ Register)]
["." arity (#+ Arity)]]]]])
(def: #export name "reset")
-(def: #export type
- (-> External (Descriptor category.Method))
- (|>> descriptor.class [(list)] descriptor.method))
+(def: #export (type class)
+ (-> (Type Class) (Type category.Method))
+ (type.method [(list) class (list)]))
+
+(def: (current-environment class)
+ (-> (Type Class) Environment (List (Instruction Any)))
+ (|>> list.size
+ list.indices
+ (list@map (///foreign.get class))))
(def: #export (method class environment arity)
- (-> External Environment Arity (State Pool Method))
+ (-> (Type Class) Environment Arity (State Pool Method))
(method.method //.modifier ..name
(..type class)
(list)
($_ _.compose
(if (arity.multiary? arity)
- ($_ _.compose
- (_.new class)
- _.dup
- (monad.map _.monad (function (_ source)
- ($_ _.compose
- ////reference.this
- (_.getfield class (////reference.foreign-name source) ////value.type)))
- (list.indices (list.size environment)))
- (///field/partial.new arity)
- (_.invokespecial class "<init>" (//new.type environment arity)))
+ (//new.instance' (..current-environment class environment) class environment arity)
////reference.this)
_.areturn)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux
index 0f4cdfec7..f17b3f2d1 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/primitive.lux
@@ -6,30 +6,29 @@
[jvm
["." constant]
["_" instruction (#+ Instruction)]
- [type
- ["|" descriptor]]]]
+ ["." type]]]
[macro
["." template]]]
["." // #_
["#." runtime]])
+(def: $Boolean (type.class "java.lang.Boolean" (list)))
+(def: $Long (type.class "java.lang.Long" (list)))
+(def: $Double (type.class "java.lang.Double" (list)))
+
(def: #export (bit value)
(-> Bit (Instruction Any))
- (_.getstatic "java.lang.Boolean"
- (if value "TRUE" "FALSE")
- (|.class "java.lang.Boolean")))
+ (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean))
(template [<name> <inputT> <ldc> <class> <inputD>]
[(def: #export (<name> value)
(-> <inputT> (Instruction Any))
(do _.monad
[_ (`` (|> value (~~ (template.splice <ldc>))))]
- (_.invokestatic <class> "valueOf"
- [(list <inputD>)
- (|.class <class>)])))]
+ (_.invokestatic <class> "valueOf" (type.method [(list <inputD>) <class> (list)]))))]
- [i64 (I64 Any) [.int constant.long _.ldc/long] "java.lang.Long" |.long]
- [f64 Frac [constant.double _.ldc/double] "java.lang.Double" |.double]
+ [i64 (I64 Any) [.int constant.long _.ldc/long] $Long type.long]
+ [f64 Frac [constant.double _.ldc/double] $Double type.double]
)
(def: #export text _.ldc/string)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
index 3e6738df0..9e60e6cda 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/reference.lux
@@ -13,15 +13,20 @@
[target
[jvm
["_" instruction (#+ Instruction)]
+ ["." type]
[encoding
["." unsigned]]]]]
["." // #_
[runtime (#+ Operation)]
["#." value]])
+(def: local
+ (-> Register (Instruction Any))
+ (|>> unsigned.u1 _.aload))
+
(def: #export this
(Instruction Any)
- (_.aload (unsigned.u1 0)))
+ (..local 0))
(template [<name> <prefix>]
[(def: #export <name>
@@ -38,13 +43,10 @@
[function-class generation.context]
(wrap ($_ _.compose
..this
- (_.getfield function-class (..foreign-name variable)
+ (_.getfield (type.class function-class (list))
+ (..foreign-name variable)
//value.type)))))
-(def: local
- (-> Register (Instruction Any))
- (|>> unsigned.u1 _.aload))
-
(def: #export (variable variable)
(-> Variable (Operation (Instruction Any)))
(case variable
@@ -58,4 +60,4 @@
(-> Name (Operation (Instruction Any)))
(do phase.monad
[bytecode-name (generation.remember name)]
- (wrap (_.getstatic bytecode-name //value.field //value.type))))
+ (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //value.type))))
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 b45965dc5..05ef66973 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
@@ -4,7 +4,11 @@
[binary (#+ Binary)]]
[target
[jvm
- ["_" instruction (#+ Label Instruction)]]]]
+ ["_" instruction (#+ Label Instruction)]
+ [encoding
+ [name (#+ External)]]
+ ["." type
+ [category (#+ Value Return Method)]]]]]
["." ///
[///
[reference (#+ Register)]]]
@@ -29,4 +33,14 @@
(type: #export (Generator i)
(-> Phase i (Operation (Instruction Any))))
-(def: #export class "LuxRuntime")
+(def: #export class (type.class "LuxRuntime" (list)))
+
+(def: apply-failure-name
+ "apply_fail")
+
+(def: apply-failure-type
+ (type.method [(list) type.void (list)]))
+
+(def: #export apply-failure
+ (Instruction Any)
+ (_.invokestatic ..class ..apply-failure-name ..apply-failure-type))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux
index 1ea837947..b75c646e8 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/structure.lux
@@ -9,10 +9,9 @@
["." list]]]
[target
[jvm
- ["_." constant]
+ ["." constant]
["_" instruction (#+ Instruction)]
- [type
- ["|" descriptor]]]]]
+ ["." type]]]]
["." // #_
["#." runtime (#+ Operation Phase Generator)]
["#." primitive]
@@ -21,10 +20,12 @@
[analysis (#+ Variant Tuple)]
["#." synthesis (#+ Synthesis)]]]])
+(def: $Object (type.class "java.lang.Object" (list)))
+
(def: unitG (Instruction Any) (//primitive.text /////synthesis.unit))
(template: (!integer <value>)
- (|> <value> .i64 i32.i32 _constant.integer))
+ (|> <value> .i64 i32.i32 constant.integer))
(def: #export (tuple generate membersS)
(Generator (Tuple Synthesis))
@@ -49,7 +50,7 @@
_.aastore))))))]
(wrap (do _.monad
[_ (_.ldc/integer (!integer (list.size membersS)))
- _ (_.anewarray "java.lang.Object")]
+ _ (_.anewarray $Object)]
(monad.seq @ membersI))))))
(def: (flagG right?)
@@ -58,8 +59,6 @@
..unitG
_.aconst-null))
-(def: $Object (|.class "java.lang.Object"))
-
(def: #export (variant generate [lefts right? valueS])
(Generator (Variant Synthesis))
(do ////.monad
@@ -71,5 +70,6 @@
_ (flagG right?)
_ valueI]
(_.invokestatic //runtime.class "variant"
- [(list |.int $Object $Object)
- (|.array $Object)])))))
+ (type.method [(list type.int $Object $Object)
+ (type.array $Object)
+ (list)]))))))
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 0dfbe4861..52fcc390a 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
@@ -2,9 +2,8 @@
[lux (#- type)
[target
[jvm
- [type
- ["." descriptor]]]]])
+ ["." type]]]])
-(def: #export field "_value")
+(def: #export field "value")
-(def: #export type (descriptor.class "java.lang.Object"))
+(def: #export type (type.class "java.lang.Object" (list)))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 34000d362..85b062009 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -1,10 +1,10 @@
(.with-expansions [<host-modules> (.as-is [runtime (#+)]
[primitive (#+)]
[structure (#+)]
- ## [function (#+)]
[reference (#+)]
## [case (#+)]
## [loop (#+)]
+ [function (#+)]
## [extension (#+)]
)]
(.module:
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 5ffe668fc..a9eb21c22 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #*
+ [lux (#- Type type)
["." host (#+ import:)]
[abstract/monad (#+ do)]
[control
@@ -42,9 +42,8 @@
["#." name]]
["#." instruction
["#/." condition (#+ Environment)]]
- [type
- [category (#+ Value)]
- ["#." descriptor (#+ Descriptor)]]]})
+ ["#." type (#+ Type)
+ [category (#+ Value)]]]})
## (def: (write-class! name bytecode)
## (-> Text Binary (IO Text))
@@ -76,45 +75,49 @@
(import: #long java/lang/Long
(#static TYPE (java/lang/Class java/lang/Long)))
-(def: descriptor
- (Random (Descriptor Value))
+(def: class-name
+ (Random Text)
+ (do random.monad
+ [super-package (random.ascii/lower-alpha 10)
+ package (random.ascii/lower-alpha 10)
+ name (random.ascii/upper-alpha 10)]
+ (wrap (format super-package
+ /name.external-separator package
+ /name.external-separator name))))
+
+(def: type
+ (Random (Type Value))
(random.rec
- (function (_ descriptor)
+ (function (_ type)
($_ random.either
- (random@wrap /descriptor.boolean)
- (random@wrap /descriptor.byte)
- (random@wrap /descriptor.short)
- (random@wrap /descriptor.int)
- (random@wrap /descriptor.long)
- (random@wrap /descriptor.float)
- (random@wrap /descriptor.double)
- (random@wrap /descriptor.char)
- (random@map (|>> (text.join-with /name.external-separator) /descriptor.class)
- (random.list 3 (random.ascii/upper-alpha 10)))
- (random@map /descriptor.array descriptor)
+ (random@wrap /type.boolean)
+ (random@wrap /type.byte)
+ (random@wrap /type.short)
+ (random@wrap /type.int)
+ (random@wrap /type.long)
+ (random@wrap /type.float)
+ (random@wrap /type.double)
+ (random@wrap /type.char)
+ (random@map (function (_ name) (/type.class name (list))) ..class-name)
+ (random@map /type.array type)
))))
(def: field
- (Random [Text (Descriptor Value)])
+ (Random [Text (Type Value)])
($_ random.and
(random.ascii/lower-alpha 10)
- ..descriptor
+ ..type
))
-(def: class-name
- (Random Text)
- (do random.monad
- [super-package (random.ascii/lower-alpha 10)
- package (random.ascii/lower-alpha 10)
- name (random.ascii/upper-alpha 10)]
- (wrap (format super-package "." package "." name))))
-
(def: (get-method name class)
(-> Text (java/lang/Class java/lang/Object) java/lang/reflect/Method)
(java/lang/Class::getDeclaredMethod name
(host.array (java/lang/Class java/lang/Object) 0)
class))
+(def: $Long (/type.class "java.lang.Long" (list)))
+(def: $Object (/type.class "java.lang.Object" (list)))
+
(def: method
Test
(do random.monad
@@ -122,7 +125,7 @@
method-name (random.ascii/upper-alpha 10)
expected random.int
#let [inputsJT (list)
- outputJT (/descriptor.class "java.lang.Object")]]
+ outputJT $Object]]
(_.test "Can compile a method."
(let [bytecode (|> (/class.class /version.v6_0 /class.public
(/name.internal class-name)
@@ -133,13 +136,12 @@
/method.public
/method.static)
method-name
- (/descriptor.method [inputsJT outputJT])
+ (/type.method [inputsJT outputJT (list)])
(list)
(do /instruction.monad
[_ (/instruction.ldc/long (/constant.long expected))
- _ (/instruction.invokestatic "java.lang.Long" "valueOf"
- [(list /descriptor.long)
- (/descriptor.class "java.lang.Long")])]
+ _ (/instruction.invokestatic $Long "valueOf"
+ (/type.method [(list /type.long) $Long (list)]))]
/instruction.areturn)))
(row.row))
(binaryF.run /class.writer))
@@ -160,15 +162,15 @@
Test
(do random.monad
[class-name ..class-name
- [field0 descriptor0] ..field
- [field1 descriptor1] ..field
+ [field0 type0] ..field
+ [field1 type1] ..field
#let [input (/class.class /version.v6_0 /class.public
(/name.internal class-name)
(/name.internal "java.lang.Object")
(list (/name.internal "java.io.Serializable")
(/name.internal "java.lang.Runnable"))
- (list (/field.field /field.public field0 descriptor0 (row.row))
- (/field.field /field.public field1 descriptor1 (row.row)))
+ (list (/field.field /field.public field0 type0 (row.row))
+ (/field.field /field.public field1 type1 (row.row)))
(list)
(row.row))
bytecode (binaryF.run /class.writer input)