aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code.lux2
-rw-r--r--stdlib/source/lux/target/jvm/attribute/code/exception.lux2
-rw-r--r--stdlib/source/lux/target/jvm/program.lux99
-rw-r--r--stdlib/source/lux/target/jvm/program/condition.lux (renamed from stdlib/source/lux/target/jvm/code/condition.lux)0
-rw-r--r--stdlib/source/lux/target/jvm/program/instruction.lux (renamed from stdlib/source/lux/target/jvm/code.lux)151
-rw-r--r--stdlib/source/lux/target/jvm/program/label.lux (renamed from stdlib/source/lux/target/jvm/code/label.lux)0
-rw-r--r--stdlib/source/lux/target/jvm/program/resources.lux (renamed from stdlib/source/lux/target/jvm/code/resources.lux)0
7 files changed, 180 insertions, 74 deletions
diff --git a/stdlib/source/lux/target/jvm/attribute/code.lux b/stdlib/source/lux/target/jvm/attribute/code.lux
index 68c651ba5..dff626c5c 100644
--- a/stdlib/source/lux/target/jvm/attribute/code.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code.lux
@@ -13,7 +13,7 @@
[collection
["." row (#+ Row) ("#@." functor fold)]]]]
["." /// #_
- [code
+ [program
["#." resources (#+ Resources)]]
[encoding
["#." unsigned (#+ U2)]]]
diff --git a/stdlib/source/lux/target/jvm/attribute/code/exception.lux b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
index 14dd13d6e..9c4c1ed38 100644
--- a/stdlib/source/lux/target/jvm/attribute/code/exception.lux
+++ b/stdlib/source/lux/target/jvm/attribute/code/exception.lux
@@ -12,7 +12,7 @@
["//#" /// #_
[constant (#+ Class)]
["#." index (#+ Index)]
- [code
+ [program
["#." label (#+ Label)]]
[encoding
["#." unsigned (#+ U2)]]]])
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
new file mode 100644
index 000000000..9d5dbe06c
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -0,0 +1,99 @@
+(.module:
+ [lux #*
+ [abstract
+ [monoid (#+ Monoid)]
+ [monad (#+ Monad do)]]
+ [control
+ ["." state (#+ State)]
+ ["." writer (#+ Writer)]
+ ["." function]]
+ [data
+ ["." error (#+ Error)]
+ [number
+ ["." nat]]
+ [collection
+ ["." dictionary (#+ Dictionary)]]]]
+ ["." / #_
+ ["#." instruction (#+ Instruction) ("#@." monoid)]
+ [//
+ [encoding
+ [unsigned (#+ U2)]]]])
+
+(type: #export Label Nat)
+
+(type: #export Jump U2)
+
+(type: #export Address Nat)
+
+(type: Resolver (Dictionary Label Address))
+
+(type: Tracker
+ {#program-counter Address
+ #next-label Label
+ #known-labels Resolver})
+
+(def: fresh
+ Tracker
+ {#program-counter 0
+ #next-label 0
+ #known-labels (dictionary.new nat.hash)})
+
+(type: #export Partial
+ (-> Resolver (Error Instruction)))
+
+(def: partial-identity
+ Partial
+ (function.constant (#error.Success /instruction.nop)))
+
+(structure: partial-monoid
+ (Monoid Partial)
+
+ (def: identity ..partial-identity)
+
+ (def: (compose left right)
+ (cond (is? ..partial-identity left)
+ right
+
+ (is? ..partial-identity right)
+ left
+
+ ## else
+ (function (_ resolver)
+ (do error.monad
+ [left (left resolver)
+ right (right resolver)]
+ (wrap (/instruction@compose left right)))))))
+
+(type: #export (Program a)
+ (State Tracker (Writer Partial a)))
+
+(def: #export new-label
+ (Program Label)
+ (function (_ tracker)
+ [(update@ #next-label inc tracker)
+ [..partial-identity
+ (get@ #next-label tracker)]]))
+
+(def: #export (set-label label)
+ (-> Label (Program Any))
+ (function (_ tracker)
+ [(update@ #known-labels
+ (dictionary.put label (get@ #program-counter tracker))
+ tracker)
+ [..partial-identity
+ []]]))
+
+(def: #export monad
+ ## TODO: Remove the coercion. It was added because the type-checker
+ ## seems to have a bug that is being triggered here.
+ (:coerce (Monad Program)
+ (writer.with ..partial-monoid
+ (: (Monad (State Tracker))
+ state.monad))))
+
+(def: #export (resolve program)
+ (All [a] (-> (Program a) (Error [Instruction a])))
+ (let [[tracker [partial output]] (state.run ..fresh program)]
+ (do error.monad
+ [instruction (partial (get@ #known-labels tracker))]
+ (wrap [instruction output]))))
diff --git a/stdlib/source/lux/target/jvm/code/condition.lux b/stdlib/source/lux/target/jvm/program/condition.lux
index 5769efc79..5769efc79 100644
--- a/stdlib/source/lux/target/jvm/code/condition.lux
+++ b/stdlib/source/lux/target/jvm/program/condition.lux
diff --git a/stdlib/source/lux/target/jvm/code.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index 480999e93..fcb2c1be7 100644
--- a/stdlib/source/lux/target/jvm/code.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #*
+ [lux (#- Code)
[abstract
[monad (#+ do)]
[monoid (#+ Monoid)]]
@@ -18,124 +18,129 @@
[type
abstract]]
["." // #_
- ["#." index (#+ Index)]
- ["#." descriptor (#+ Field Method)]
- ["#." constant (#+ Class Reference)]
- [encoding
- ["#." unsigned (#+ U1 U2 U4)]]]
- ["." / #_
["#." resources (#+ Resources)]
- ["#" condition (#+ Environment Condition Local) ("#@." monoid)]
- ["#." label (#+ Label Wide-Label)]])
+ ["/" condition (#+ Environment Condition Local) ("#@." monoid)]
+ ["#." label (#+ Label Wide-Label)]
+ ["/#" // #_
+ ["#." index (#+ Index)]
+ ["#." descriptor (#+ Field Method)]
+ ["#." constant (#+ Class Reference)]
+ [encoding
+ ["#." unsigned (#+ U1 U2 U4)]]]])
+
+(type: #export Size Nat)
(type: #export Instruction
- (-> [Environment Specification] (Error [Environment Specification])))
+ [Size (-> [Environment Specification] (Error [Environment Specification]))])
+
+(def: (instruction size condition transform)
+ (-> Size Condition (-> Specification Specification) Instruction)
+ [size
+ (function (_ [environment specification])
+ (do error.monad
+ [environment' (condition environment)]
+ (wrap [environment'
+ (transform specification)])))])
-(def: (instruction condition transform)
- (-> Condition (-> Specification Specification) Instruction)
- (function (_ [environment specification])
- (do error.monad
- [environment' (condition environment)]
- (wrap [environment'
- (transform specification)]))))
+(type: Code Nat)
(def: (nullary' code)
- (-> Nat Mutation)
+ (-> Code Mutation)
(function (_ [offset binary])
[(n/+ 1 offset)
(error.assume
(binary.write/8 offset code binary))]))
(def: (nullary code [size mutation])
- (-> Nat (-> Specification Specification))
+ (-> Code (-> Specification Specification))
[(n/+ 1 size)
(|>> mutation ((nullary' code)))])
(def: (unary/1' code input0)
- (-> Nat U1 Mutation)
+ (-> Code U1 Mutation)
(function (_ [offset binary])
[(n/+ 2 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)]
- (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+ (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
(def: (unary/1 code input0 [size mutation])
- (-> Nat U1 (-> Specification Specification))
+ (-> Code U1 (-> Specification Specification))
[(n/+ 2 size)
(|>> mutation ((unary/1' code input0)))])
(def: (unary/2' code input0)
- (-> Nat U2 Mutation)
+ (-> Code U2 Mutation)
(function (_ [offset binary])
[(n/+ 3 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)]
- (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
(def: (unary/2 code input0 [size mutation])
- (-> Nat U2 (-> Specification Specification))
+ (-> Code U2 (-> Specification Specification))
[(n/+ 3 size)
(|>> mutation ((unary/2' code input0)))])
(def: (unary/4' code input0)
- (-> Nat U4 Mutation)
+ (-> Code U4 Mutation)
(function (_ [offset binary])
[(n/+ 5 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)]
- (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)))]))
+ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
(def: (unary/4 code input0 [size mutation])
- (-> Nat U4 (-> Specification Specification))
+ (-> Code U4 (-> Specification Specification))
[(n/+ 5 size)
(|>> mutation ((unary/4' code input0)))])
(def: (binary/11' code input0 input1)
- (-> Nat U1 U1 Mutation)
+ (-> Code U1 U1 Mutation)
(function (_ [offset binary])
[(n/+ 3 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)
- _ (binary.write/8 (n/+ 1 offset) (//unsigned.nat input0) binary)]
- (binary.write/8 (n/+ 2 offset) (//unsigned.nat input1) binary)))]))
+ _ (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)]
+ (binary.write/8 (n/+ 2 offset) (///unsigned.nat input1) binary)))]))
(def: (binary/11 code input0 input1 [size mutation])
- (-> Nat U1 U1 (-> Specification Specification))
+ (-> Code U1 U1 (-> Specification Specification))
[(n/+ 3 size)
(|>> mutation ((binary/11' code input0 input1)))])
(def: (binary/21' code input0 input1)
- (-> Nat U2 U1 Mutation)
+ (-> Code U2 U1 Mutation)
(function (_ [offset binary])
[(n/+ 4 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)
- _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)]
- (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)))]))
+ _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)]
+ (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)))]))
(def: (binary/21 code input0 input1 [size mutation])
- (-> Nat U2 U1 (-> Specification Specification))
+ (-> Code U2 U1 (-> Specification Specification))
[(n/+ 4 size)
(|>> mutation ((binary/21' code input0 input1)))])
(def: (trinary/211' code input0 input1 input2)
- (-> Nat U2 U1 U1 Mutation)
+ (-> Code U2 U1 U1 Mutation)
(function (_ [offset binary])
[(n/+ 5 offset)
(error.assume
(do error.monad
[_ (binary.write/8 offset code binary)
- _ (binary.write/16 (n/+ 1 offset) (//unsigned.nat input0) binary)
- _ (binary.write/8 (n/+ 3 offset) (//unsigned.nat input1) binary)]
- (binary.write/8 (n/+ 4 offset) (//unsigned.nat input2) binary)))]))
+ _ (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)
+ _ (binary.write/8 (n/+ 3 offset) (///unsigned.nat input1) binary)]
+ (binary.write/8 (n/+ 4 offset) (///unsigned.nat input2) binary)))]))
(def: (trinary/211 code input0 input1 input2 [size mutation])
- (-> Nat U2 U1 U1 (-> Specification Specification))
+ (-> Code U2 U1 U1 (-> Specification Specification))
[(n/+ 5 size)
(|>> mutation ((trinary/211' code input0 input1 input2)))])
@@ -149,7 +154,7 @@
(|>> :representation))
(template [<code> <name>]
- [(def: #export <name> (|> <code> //unsigned.u1 :abstraction))]
+ [(def: #export <name> (|> <code> ///unsigned.u1 :abstraction))]
[04 t-boolean]
[05 t-char]
@@ -193,7 +198,7 @@
["18" dload 2]
["19" aload 1])
<simple-local-loads> (template [<code> <name> <output-size> <local-end>]
- [[<code> <name> [] [] 0 <output-size> [[(//unsigned.u1 <local-end>)]]]]
+ [[<code> <name> [] [] 0 <output-size> [[(///unsigned.u1 <local-end>)]]]]
["1A" iload-0 1 0]
["1B" iload-1 1 1]
@@ -228,7 +233,7 @@
["39" dstore 2]
["3A" astore 1])
<simple-local-stores> (template [<code> <name> <input-size> <local-end>]
- [[<code> <name> [] [] <input-size> 0 [[(//unsigned.u1 <local-end>)]]]]
+ [[<code> <name> [] [] <input-size> 0 [[(///unsigned.u1 <local-end>)]]]]
["3B" istore-0 1 0]
["3C" istore-1 1 1]
@@ -382,13 +387,13 @@
["C6" ifnull 1 0]
["C7" ifnonnull 1 0])
<fields> (template [<code> <name> <input-size> <output-size>]
- [[<code> <name> [[index (Index (Reference Field))]] [(//index.number index)] <input-size> <output-size> []]]
+ [[<code> <name> [[index (Index (Reference Field))]] [(///index.number index)] <input-size> <output-size> []]]
["B2" getstatic/1 0 1] ["B2" getstatic/2 0 2]
["B3" putstatic/1 1 1] ["B3" putstatic/2 1 2]
["B4" getfield/1 1 1] ["B4" getfield/2 1 2]
["B5" putfield/1 2 1] ["B5" putfield/2 2 2])]
- (template [<arity> <definitions>]
+ (template [<arity> <size> <definitions>]
[(with-expansions [<definitions>' (template.splice <definitions>)]
(template [<code> <name> <instruction-inputs> <arity-inputs> <consumes> <produces> <locals>]
[(with-expansions [<inputs>' (template.splice <instruction-inputs>)
@@ -404,6 +409,7 @@
(def: #export (<name> <input-names>)
(-> <input-types> Instruction)
(..instruction
+ <size>
(`` ($_ /@compose
(/.consumes <consumes>)
(/.produces <produces>)
@@ -416,7 +422,7 @@
<definitions>'
))]
- [..nullary
+ [..nullary 1
[["00" nop [] [] 0 0 []]
<constants>
["57" pop [] [] 1 0 []]
@@ -444,7 +450,7 @@
["C2" monitorenter [] [] 1 0 []]
["C3" monitorexit [] [] 1 0 []]]]
- [..unary/1
+ [..unary/1 2
[["10" bipush [[byte U1]] [byte] 0 1 []]
["12" ldc [[index U1]] [index] 0 1 []]
<local-loads>
@@ -452,34 +458,34 @@
["A9" ret [[local Local]] [local] 0 0 [[local]]]
["BC" newarray [[type Primitive-Array-Type]] [(..code type)] 1 1 []]]]
- [..unary/2
+ [..unary/2 3
[["11" sipush [[short U2]] [short] 0 1 []]
- ["13" ldc-w/integer [[index (Index //constant.Integer)]] [(//index.number index)] 0 1 []]
- ["13" ldc-w/float [[index (Index //constant.Float)]] [(//index.number index)] 0 1 []]
- ["14" ldc2-w/long [[index (Index //constant.Long)]] [(//index.number index)] 0 1 []]
- ["14" ldc2-w/double [[index (Index //constant.Double)]] [(//index.number index)] 0 1 []]
+ ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []]
+ ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []]
+ ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 1 []]
+ ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 1 []]
<jumps>
<fields>
- ["BB" new [[index (Index Class)]] [(//index.number index)] 0 1 []]
- ["BD" anewarray [[index (Index Class)]] [(//index.number index)] 1 1 []]
- ["C0" checkcast [[index (Index Class)]] [(//index.number index)] 1 1 []]
- ["C1" instanceof [[index (Index Class)]] [(//index.number index)] 1 1 []]
- ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]
- ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]
- ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index)] (//unsigned.nat count) (//unsigned.nat output-count) []]]]
-
- [..unary/4
+ ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []]
+ ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []]
+ ["C0" checkcast [[index (Index Class)]] [(///index.number index)] 1 1 []]
+ ["C1" instanceof [[index (Index Class)]] [(///index.number index)] 1 1 []]
+ ["B6" invokevirtual [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]
+ ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]
+ ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
+
+ [..unary/4 5
[["C8" goto-w [[label Wide-Label]] [label] 0 0 []]
["C9" jsr-w [[label Wide-Label]] [label] 0 1 []]]]
- [..binary/11
+ [..binary/11 3
[["84" iinc [[local Local] [byte U1]] [local byte] 0 0 [[local]]]]]
- [..binary/21
- [["C5" multianewarray [[index (Index Class)] [count U1]] [(//index.number index) count] (//unsigned.nat count) 1 []]]]
+ [..binary/21 4
+ [["C5" multianewarray [[index (Index Class)] [count U1]] [(///index.number index) count] (///unsigned.nat count) 1 []]]]
- [..trinary/211
- [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(//index.number index) count (//unsigned.u1 0)] (//unsigned.nat count) (//unsigned.nat output-count) []]]]
+ [..trinary/211 5
+ [["B9" invokeinterface [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index) count (///unsigned.u1 0)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
))
(structure: #export monoid
@@ -487,8 +493,9 @@
(def: identity ..nop)
- (def: (compose left right)
- (function (_ input)
- (do error.monad
- [temp (left input)]
- (right temp)))))
+ (def: (compose [left-size left] [right-size right])
+ [(n/+ left-size right-size)
+ (function (_ input)
+ (do error.monad
+ [temp (left input)]
+ (right temp)))]))
diff --git a/stdlib/source/lux/target/jvm/code/label.lux b/stdlib/source/lux/target/jvm/program/label.lux
index 7aaff5739..7aaff5739 100644
--- a/stdlib/source/lux/target/jvm/code/label.lux
+++ b/stdlib/source/lux/target/jvm/program/label.lux
diff --git a/stdlib/source/lux/target/jvm/code/resources.lux b/stdlib/source/lux/target/jvm/program/resources.lux
index fed6d4ce7..fed6d4ce7 100644
--- a/stdlib/source/lux/target/jvm/code/resources.lux
+++ b/stdlib/source/lux/target/jvm/program/resources.lux
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 12:45:07 +0000