aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/encoding/signed.lux81
-rw-r--r--stdlib/source/lux/target/jvm/program.lux9
-rw-r--r--stdlib/source/lux/target/jvm/program/instruction.lux71
-rw-r--r--stdlib/source/lux/target/jvm/program/jump.lux12
4 files changed, 119 insertions, 54 deletions
diff --git a/stdlib/source/lux/target/jvm/encoding/signed.lux b/stdlib/source/lux/target/jvm/encoding/signed.lux
new file mode 100644
index 000000000..7765d4402
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/encoding/signed.lux
@@ -0,0 +1,81 @@
+(.module:
+ [lux (#- int)
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [control
+ ["<>" parser ("#@." functor)
+ ["<2>" binary (#+ Parser)]]]
+ [data
+ [number
+ ["." i64]]
+ [format
+ [".F" binary (#+ Writer)]]]
+ [macro
+ ["." template]]
+ [type
+ abstract]])
+
+(abstract: #export (Signed brand)
+ {}
+ Int
+
+ (def: #export int
+ (-> (Signed Any) Int)
+ (|>> :representation))
+
+ (structure: #export equivalence
+ (All [brand] (Equivalence (Signed brand)))
+ (def: (= reference sample)
+ (i/= (:representation reference) (:representation sample))))
+
+ (structure: #export order
+ (All [brand] (Order (Signed brand)))
+
+ (def: &equivalence ..equivalence)
+ (def: (< reference sample)
+ (i/< (:representation reference) (:representation sample))))
+
+ (template [<bytes> <name> <size> <constructor> <max> <+>]
+ [(with-expansions [<raw> (template.identifier [<name> "'"])]
+ (abstract: #export <raw> {} Any)
+ (type: #export <name> (Signed <raw>)))
+
+ (def: #export <size> Nat <bytes>)
+
+ (def: #export <max>
+ <name>
+ (|> <bytes> (n/* i64.bits-per-byte) dec i64.mask :abstraction))
+
+ (def: #export <constructor>
+ (-> Int <name>)
+ (let [limit (|> <bytes> (n/* i64.bits-per-byte) i64.mask .nat)]
+ (|>> (i64.and limit) :abstraction)))
+
+ (def: #export (<+> parameter subject)
+ (-> <name> <name> <name>)
+ (let [limit (|> <bytes> (n/* i64.bits-per-byte) i64.mask .nat)]
+ (:abstraction
+ (i64.and limit
+ (i/+ (:representation parameter)
+ (:representation subject))))))]
+
+ [1 S1 s1-bytes s1 max-s1 s1/+]
+ [2 S2 s2-bytes s2 max-s2 s2/+]
+ [4 S4 s4-bytes s4 max-s4 s4/+]
+ )
+ )
+
+(template [<parser-name> <writer-name> <type> <parser> <writer> <post-read>]
+ [(def: #export <parser-name>
+ (Parser <type>)
+ (<>@map (|>> .int <post-read>) <parser>))
+
+ (def: #export <writer-name>
+ (Writer <type>)
+ (|>> ..int <writer>))]
+
+ [s1-parser s1-writer S1 <2>.bits/8 binaryF.bits/8 ..s1]
+ [s2-parser s2-writer S2 <2>.bits/16 binaryF.bits/16 ..s2]
+ [s4-parser s4-writer S4 <2>.bits/32 binaryF.bits/32 ..s4]
+ )
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
index 774094c5b..61e5a9046 100644
--- a/stdlib/source/lux/target/jvm/program.lux
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -23,7 +23,8 @@
["/#" // #_
["#." index]
[encoding
- ["#." unsigned (#+ U1 U2)]]
+ ["#." unsigned (#+ U1 U2)]
+ ["#." signed]]
["#." constant (#+ UTF8)
["#/."pool (#+ Pool)]]]])
@@ -343,7 +344,7 @@
(exception.report
["Label" (%.nat label)]
["Start" (%.nat @from)]
- ["Target" (|> jump //unsigned.nat .int %.int)]))
+ ["Target" (|> jump //signed.int %.int)]))
(def: (jump @from @to)
(-> Address Address (Either Jump Big-Jump))
@@ -354,8 +355,8 @@
-1)
jump)))]
(if big?
- (#.Right (//unsigned.u4 (.nat jump)))
- (#.Left (//unsigned.u2 (.nat jump))))))
+ (#.Right (//signed.s4 jump))
+ (#.Left (//signed.s2 jump)))))
(template [<name> <instruction>]
[(def: #export (<name> label)
diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index 83efb98b7..375204cc8 100644
--- a/stdlib/source/lux/target/jvm/program/instruction.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -26,7 +26,8 @@
["#." descriptor (#+ Field Method)]
["#." constant (#+ Class Reference)]
[encoding
- ["#." unsigned (#+ U1 U2 U4)]]]])
+ ["#." unsigned (#+ U1 U2 U4)]
+ ["#." signed (#+ S2 S4)]]]])
(type: #export Size Nat)
@@ -56,47 +57,27 @@
[(n/+ 1 size)
(|>> mutation ((nullary' code)))])
-(def: (unary/1' code input0)
- (-> Code U1 Mutation)
- (function (_ [offset binary])
- [(n/+ 2 offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset code binary)]
- (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/1 code input0 [size mutation])
- (-> Code U1 (-> Specification Specification))
- [(n/+ 2 size)
- (|>> mutation ((unary/1' code input0)))])
-
-(def: (unary/2' code input0)
- (-> Code U2 Mutation)
- (function (_ [offset binary])
- [(n/+ 3 offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset code binary)]
- (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/2 code input0 [size mutation])
- (-> Code U2 (-> Specification Specification))
- [(n/+ 3 size)
- (|>> mutation ((unary/2' code input0)))])
-
-(def: (unary/4' code input0)
- (-> Code U4 Mutation)
- (function (_ [offset binary])
- [(n/+ 5 offset)
- (try.assume
- (do try.monad
- [_ (binary.write/8 offset code binary)]
- (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/4 code input0 [size mutation])
- (-> Code U4 (-> Specification Specification))
- [(n/+ 5 size)
- (|>> mutation ((unary/4' code input0)))])
+(template [<shift> <name> <inputT> <writer> <unwrap>]
+ [(with-expansions [<private> (template.identifier [<name> "'"])]
+ (def: (<private> code input0)
+ (-> Code <inputT> Mutation)
+ (function (_ [offset binary])
+ [(n/+ <shift> offset)
+ (try.assume
+ (do try.monad
+ [_ (binary.write/8 offset code binary)]
+ (<writer> (n/+ 1 offset) (<unwrap> input0) binary)))]))
+
+ (def: (<name> code input0 [size mutation])
+ (-> Code <inputT> (-> Specification Specification))
+ [(n/+ <shift> size)
+ (|>> mutation ((<private> code input0)))]))]
+
+ [2 unary/1 U1 binary.write/8 ///unsigned.nat]
+ [3 unary/2 U2 binary.write/16 ///unsigned.nat]
+ [3 jump/2 S2 binary.write/16 ///signed.int]
+ [5 jump/4 S4 binary.write/32 ///signed.int]
+ )
(def: (binary/11' code input0 input1)
(-> Code U1 U1 Mutation)
@@ -464,7 +445,6 @@
["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 []]
@@ -474,7 +454,10 @@
["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
+ [..jump/2 3
+ [<jumps>]]
+
+ [..jump/4 5
[["C8" goto-w [[jump Big-Jump]] [jump] 0 0 []]
["C9" jsr-w [[jump Big-Jump]] [jump] 0 1 []]]]
diff --git a/stdlib/source/lux/target/jvm/program/jump.lux b/stdlib/source/lux/target/jvm/program/jump.lux
index 49a4e42ea..00b66bede 100644
--- a/stdlib/source/lux/target/jvm/program/jump.lux
+++ b/stdlib/source/lux/target/jvm/program/jump.lux
@@ -4,17 +4,17 @@
[equivalence (#+ Equivalence)]]]
["." /// #_
[encoding
- ["#." unsigned (#+ U2 U4)]]])
+ ["#." signed (#+ S2 S4)]]])
-(type: #export Jump U2)
+(type: #export Jump S2)
(def: #export equivalence
- ///unsigned.equivalence)
+ ///signed.equivalence)
(def: #export parser
- ///unsigned.u2-parser)
+ ///signed.s2-parser)
(def: #export writer
- ///unsigned.u2-writer)
+ ///signed.s2-writer)
-(type: #export Big-Jump U4)
+(type: #export Big-Jump S4)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 12:15:47 +0000