aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator')
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux2
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/def.lux6
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux133
-rw-r--r--new-luxc/source/luxc/generator/primitive.jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/procedure.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux263
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux147
-rw-r--r--new-luxc/source/luxc/generator/structure.jvm.lux16
9 files changed, 359 insertions, 228 deletions
diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux
index 0dd19d032..c5fe8fc0a 100644
--- a/new-luxc/source/luxc/generator/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/common.jvm.lux
@@ -5,7 +5,11 @@
(data ["R" result]
(coll ["d" dict])
text/format)
- [host #+ jvm-import]))
+ [host #+ jvm-import])
+ (luxc (generator (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
## [Host]
(jvm-import org.objectweb.asm.Opcodes
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 32f8bde31..0bdebe555 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -26,7 +26,7 @@
[#ls;Nat &primitive;generate-nat]
[#ls;Int &primitive;generate-int]
[#ls;Deg &primitive;generate-deg]
- [#ls;Real &primitive;generate-real]
+ [#ls;Frac &primitive;generate-frac]
[#ls;Text &primitive;generate-text])
(#ls;Variant tag tail? member)
diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
index 8931db940..8b961b29a 100644
--- a/new-luxc/source/luxc/generator/host/jvm/def.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -62,7 +62,7 @@
(-> (List Text) (a;Array Text))
(let [output (host;array String (list;size values))]
(exec (L/map (function [[idx value]]
- (host;array-store idx value output))
+ (host;array-write idx value output))
(list;enumerate values))
output)))
@@ -261,8 +261,8 @@
[short-field Int $t;short host;l2s]
[int-field Int $t;int host;l2i]
[long-field Int $t;long id]
- [float-field Real $t;float host;d2f]
- [double-field Real $t;double id]
+ [float-field Frac $t;float host;d2f]
+ [double-field Frac $t;double id]
[char-field Nat $t;char (|>. nat-to-int host;l2i host;i2c)]
[string-field Text ($t;class "java.lang.String" (list)) id]
)
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 30148c4e5..af5f6f6d8 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -22,12 +22,18 @@
(with-expansions [<primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
T_BYTE T_SHORT T_INT T_LONG)
- <stack> (declare DUP DUP2_X1
+ <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2
POP POP2
SWAP)
<jump> (declare IF_ICMPEQ IF_ACMPEQ IFNULL
- IFLT IFLE IFGT IFGE
- GOTO)]
+ IFEQ IFLT IFLE IFGT IFGE
+ GOTO)
+ <var> (declare ILOAD LLOAD DLOAD ALOAD
+ ISTORE LSTORE)
+ <arithmethic> (declare IADD ISUB
+ LADD LSUB LMUL LDIV LREM LCMP
+ DADD DSUB DMUL DDIV DREM DCMPG)
+ <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
(jvm-import org.objectweb.asm.Opcodes
<primitive>
@@ -41,11 +47,7 @@
(#static ACONST_NULL int)
- (#static ILOAD int)
- (#static LLOAD int)
- (#static ALOAD int)
-
- (#static IADD int)
+ <var>
(#static LAND int)
(#static LOR int)
@@ -54,19 +56,7 @@
(#static LSHR int)
(#static LUSHR int)
- (#static LADD int)
- (#static LSUB int)
- (#static LMUL int)
- (#static LDIV int)
- (#static LREM int)
- (#static LCMP int)
-
- (#static DADD int)
- (#static DSUB int)
- (#static DMUL int)
- (#static DDIV int)
- (#static DREM int)
- (#static DCMPG int)
+ <arithmethic>
(#static I2L int)
(#static L2I int)
@@ -89,10 +79,7 @@
(#static ATHROW int)
- (#static RETURN int)
- (#static IRETURN int)
- (#static LRETURN int)
- (#static ARETURN int)
+ <return>
))
(jvm-import org.objectweb.asm.FieldVisitor
@@ -113,7 +100,8 @@
(visitIntInsn [int int] void)
(visitMethodInsn [int String String String boolean] void)
(visitLabel [Label] void)
- (visitJumpInsn [int Label] void))
+ (visitJumpInsn [int Label] void)
+ (visitTryCatchBlock [Label Label Label String] void))
## [Insts]
(def: #export (with-label action)
@@ -130,7 +118,7 @@
[boolean Bool id]
[int Int host;l2i]
[long Int id]
- [double Real id]
+ [double Frac id]
[char Nat (|>. nat-to-int host;l2i host;i2c)]
[string Text id]
)
@@ -152,14 +140,14 @@
(MethodVisitor.visitInsn [(prefix <name>)]))))]
## Stack
- [DUP] [DUP2_X1] [POP] [POP2] [SWAP]
-
- ## Integer arithmetic
- [IADD]
+ [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP]
## Long bitwise
[LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+ ## Integer arithmetic
+ [IADD] [ISUB]
+
## Long arithmethic
[LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP]
@@ -176,19 +164,18 @@
[ATHROW]
## Return
- [RETURN] [IRETURN] [LRETURN] [ARETURN]
+ [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
)
-(do-template [<name> <inst>]
+(do-template [<name>]
[(def: #export (<name> register)
(-> Nat $;Inst)
(function [visitor]
(do-to visitor
- (MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]
+ (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))]
- [ILOAD Opcodes.ILOAD]
- [LLOAD Opcodes.LLOAD]
- [ALOAD Opcodes.ALOAD]
+ [ILOAD] [LLOAD] [DLOAD] [ALOAD]
+ [ISTORE] [LSTORE]
)
(do-template [<name> <inst>]
@@ -251,10 +238,16 @@
(MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
[IF_ICMPEQ] [IF_ACMPEQ] [IFNULL]
- [IFLT] [IFLE] [IFGT] [IFGE]
+ [IFEQ] [IFLT] [IFLE] [IFGT] [IFGE]
[GOTO]
)
+(def: #export (try @from @to @handler exception)
+ (-> $;Label $;Label $;Label Text $;Inst)
+ (function [visitor]
+ (do-to visitor
+ (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)]))))
+
(def: #export (label @label)
(-> $;Label $;Inst)
(function [visitor]
@@ -282,30 +275,46 @@
(|>. (int (nat-to-int size))
(ANEWARRAY ($t;descriptor type)))))
-(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim>]
- [(def: #export <wrap>
- $;Inst
- (|>. (INVOKESTATIC <class> "valueOf"
- ($t;method (list <prim>)
- (#;Some ($t;class <class> (list)))
- (list))
- false)))
- (def: #export <unwrap>
- $;Inst
- (|>. (CHECKCAST <class>)
- (INVOKEVIRTUAL <class> <unwrap-method>
- ($t;method (list) (#;Some <prim>) (list))
- false)))]
-
- [wrap-boolean unwrap-boolean "java.lang.Boolean" "booleanValue" $t;boolean]
- [wrap-byte unwrap-byte "java.lang.Byte" "byteValue" $t;byte]
- [wrap-short unwrap-short "java.lang.Short" "shortValue" $t;short]
- [wrap-int unwrap-int "java.lang.Integer" "intValue" $t;int]
- [wrap-long unwrap-long "java.lang.Long" "longValue" $t;long]
- [wrap-float unwrap-float "java.lang.Float" "floatValue" $t;float]
- [wrap-double unwrap-double "java.lang.Double" "doubleValue" $t;double]
- [wrap-char unwrap-char "java.lang.Character" "charValue" $t;char]
- )
+(def: (primitive-wrapper type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "java.lang.Boolean"
+ #$;Byte "java.lang.Byte"
+ #$;Short "java.lang.Short"
+ #$;Int "java.lang.Integer"
+ #$;Long "java.lang.Long"
+ #$;Float "java.lang.Float"
+ #$;Double "java.lang.Double"
+ #$;Char "java.lang.Character"))
+
+(def: (primitive-unwrap type)
+ (-> $;Primitive Text)
+ (case type
+ #$;Boolean "booleanValue"
+ #$;Byte "byteValue"
+ #$;Short "shortValue"
+ #$;Int "intValue"
+ #$;Long "longValue"
+ #$;Float "floatValue"
+ #$;Double "doubleValue"
+ #$;Char "charValue"))
+
+(def: #export (wrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (INVOKESTATIC class "valueOf"
+ ($t;method (list (#$;Primitive type))
+ (#;Some ($t;class class (list)))
+ (list))
+ false))))
+
+(def: #export (unwrap type)
+ (-> $;Primitive $;Inst)
+ (let [class (primitive-wrapper type)]
+ (|>. (CHECKCAST class)
+ (INVOKEVIRTUAL class (primitive-unwrap type)
+ ($t;method (list) (#;Some (#$;Primitive type)) (list))
+ false))))
(def: #export (fuse insts)
(-> (List $;Inst) $;Inst)
diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux
index 2cb01a6aa..a63aa8596 100644
--- a/new-luxc/source/luxc/generator/primitive.jvm.lux
+++ b/new-luxc/source/luxc/generator/primitive.jvm.lux
@@ -29,9 +29,9 @@
(-> <type> (Lux $;Inst))
(Lux/wrap (|>. (<load> value) <wrap>)))]
- [generate-nat Nat (|>. (:! Int) $i;long) $i;wrap-long]
- [generate-int Int $i;long $i;wrap-long]
- [generate-deg Deg (|>. (:! Int) $i;long) $i;wrap-long]
- [generate-real Real $i;double $i;wrap-double]
+ [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
+ [generate-int Int $i;long ($i;wrap #$;Long)]
+ [generate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)]
+ [generate-frac Frac $i;double ($i;wrap #$;Double)]
[generate-text Text $i;string id]
)
diff --git a/new-luxc/source/luxc/generator/procedure.jvm.lux b/new-luxc/source/luxc/generator/procedure.jvm.lux
index 258d90689..77828c952 100644
--- a/new-luxc/source/luxc/generator/procedure.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure.jvm.lux
@@ -1,9 +1,9 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data text/format
- maybe
+ [maybe]
(coll ["d" dict])))
(luxc ["&" base]
(lang ["ls" synthesis])
@@ -14,6 +14,6 @@
(-> (-> ls;Synthesis (Lux $;Inst)) Text (List ls;Synthesis)
(Lux $;Inst))
(default (&;fail (format "Unknown procedure: " (%t name)))
- (do Monad<Maybe>
+ (do maybe;Monad<Maybe>
[proc (d;get name &&common;procedures)]
(wrap (proc generate args)))))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index fcfba7682..106b6a0f5 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -1,6 +1,6 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data [text]
text/format
(coll [list "L/" Functor<List> Monoid<List>]
@@ -72,7 +72,7 @@
(syntax: (arity: [name s;local-symbol] [arity s;nat])
(with-gensyms [g!proc g!name g!generate g!inputs]
(do @
- [g!input+ (seqM @ (list;repeat arity (macro;gensym "input")))]
+ [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))]
(wrap (list (` (def: ((~ (code;local-symbol name)) (~ g!proc))
(-> (-> (Vector (~ (code;nat arity)) $;Inst) $;Inst)
(-> Text Proc))
@@ -96,27 +96,8 @@
(arity: trinary +3)
## [Instructions]
-(def: some-method
- $;Method
- ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
-
-(def: make-someI
- $;Inst
- (|>. ($i;int 1)
- ($i;string "")
- $i;DUP2_X1
- $i;POP2
- ($i;INVOKESTATIC &runtime;runtime-name "sum_make" some-method false)))
-
-(def: make-noneI
- $;Inst
- (|>. ($i;int 9)
- $i;NULL
- ($i;string &runtime;unit)
- ($i;INVOKESTATIC &runtime;runtime-name "sum_make" some-method false)))
-
-(def: lux-intI $;Inst (|>. $i;I2L $i;wrap-long))
-(def: jvm-intI $;Inst (|>. $i;unwrap-long $i;L2I))
+(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long)))
+(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I))
(def: (array-writeI arrayI idxI elemI)
(-> $;Inst $;Inst $;Inst
@@ -161,9 +142,9 @@
(do-template [<name> <op>]
[(def: (<name> [inputI maskI])
Binary
- (|>. inputI $i;unwrap-long
- maskI $i;unwrap-long
- <op> $i;wrap-long))]
+ (|>. inputI ($i;unwrap #$;Long)
+ maskI ($i;unwrap #$;Long)
+ <op> ($i;wrap #$;Long)))]
[bit//and $i;LAND]
[bit//or $i;LOR]
@@ -172,17 +153,17 @@
(def: (bit//count inputI)
Unary
- (|>. inputI $i;unwrap-long
+ (|>. inputI ($i;unwrap #$;Long)
($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false)
lux-intI))
(do-template [<name> <op>]
[(def: (<name> [inputI shiftI])
Binary
- (|>. inputI $i;unwrap-long
+ (|>. inputI ($i;unwrap #$;Long)
shiftI jvm-intI
<op>
- $i;wrap-long))]
+ ($i;wrap #$;Long)))]
[bit//shift-left $i;LSHL]
[bit//shift-right $i;LSHR]
@@ -203,11 +184,11 @@
$i;AALOAD
$i;DUP
($i;IFNULL @is-null)
- make-someI
+ &runtime;someI
($i;GOTO @end)
($i;label @is-null)
$i;POP
- make-noneI
+ &runtime;noneI
($i;label @end))))
(def: (array//put [arrayI idxI elemI])
@@ -240,21 +221,21 @@
Nullary
(|>. <const> <wrapper>))]
- [nat//min ($i;long 0) $i;wrap-long]
- [nat//max ($i;long -1) $i;wrap-long]
+ [nat//min ($i;long 0) ($i;wrap #$;Long)]
+ [nat//max ($i;long -1) ($i;wrap #$;Long)]
- [int//min ($i;long Long.MIN_VALUE) $i;wrap-long]
- [int//max ($i;long Long.MAX_VALUE) $i;wrap-long]
+ [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)]
+ [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)]
- [real//smallest ($i;double Double.MIN_VALUE) $i;wrap-double]
- [real//min ($i;double (r.* -1.0 Double.MAX_VALUE)) $i;wrap-double]
- [real//max ($i;double Double.MAX_VALUE) $i;wrap-double]
- [real//not-a-number ($i;double Double.NaN) $i;wrap-double]
- [real//positive-infinity ($i;double Double.POSITIVE_INFINITY) $i;wrap-double]
- [real//negative-infinity ($i;double Double.NEGATIVE_INFINITY) $i;wrap-double]
-
- [deg//min ($i;long 0) $i;wrap-long]
- [deg//max ($i;long -1) $i;wrap-long]
+ [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)]
+ [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)]
+ [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)]
+ [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)]
+ [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)]
+ [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)]
+
+ [deg//min ($i;long 0) ($i;wrap #$;Long)]
+ [deg//max ($i;long -1) ($i;wrap #$;Long)]
)
(do-template [<name> <unwrap> <wrap> <op>]
@@ -265,57 +246,53 @@
<op>
<wrap>))]
- [int//add $i;unwrap-long $i;wrap-long $i;LADD]
- [int//sub $i;unwrap-long $i;wrap-long $i;LSUB]
- [int//mul $i;unwrap-long $i;wrap-long $i;LMUL]
- [int//div $i;unwrap-long $i;wrap-long $i;LDIV]
- [int//rem $i;unwrap-long $i;wrap-long $i;LREM]
+ [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
+ [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
+ [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
+ [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
+ [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM]
- [nat//add $i;unwrap-long $i;wrap-long $i;LADD]
- [nat//sub $i;unwrap-long $i;wrap-long $i;LSUB]
- [nat//mul $i;unwrap-long $i;wrap-long $i;LMUL]
- [nat//div $i;unwrap-long $i;wrap-long
+ [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
+ [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
+ [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
+ [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "div_nat" nat-method false)]
- [nat//rem $i;unwrap-long $i;wrap-long
+ [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "rem_nat" nat-method false)]
- [real//add $i;unwrap-double $i;wrap-double $i;DADD]
- [real//sub $i;unwrap-double $i;wrap-double $i;DSUB]
- [real//mul $i;unwrap-double $i;wrap-double $i;DMUL]
- [real//div $i;unwrap-double $i;wrap-double $i;DDIV]
- [real//rem $i;unwrap-double $i;wrap-double $i;DREM]
+ [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD]
+ [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB]
+ [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL]
+ [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV]
+ [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM]
- [deg//add $i;unwrap-long $i;wrap-long $i;LADD]
- [deg//sub $i;unwrap-long $i;wrap-long $i;LSUB]
- [deg//mul $i;unwrap-long $i;wrap-long
+ [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
+ [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
+ [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "mul_deg" deg-method false)]
- [deg//div $i;unwrap-long $i;wrap-long
+ [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
($i;INVOKESTATIC &runtime;runtime-name "div_deg" deg-method false)]
- [deg//rem $i;unwrap-long $i;wrap-long $i;LSUB]
- [deg//scale $i;unwrap-long $i;wrap-long $i;LMUL]
- [deg//reciprocal $i;unwrap-long $i;wrap-long $i;LDIV]
+ [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
+ [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
+ [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
)
-(do-template [<name> <reference> <unwrap> <cmp>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
- <cmp>
- ($i;int <reference>)
- (predicateI $i;IF_ICMPEQ)))]
-
- [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
- [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
-
- [int//eq 0 $i;unwrap-long $i;LCMP]
- [int//lt -1 $i;unwrap-long $i;LCMP]
-
- [real//eq 0 $i;unwrap-double $i;DCMPG]
- [real//lt -1 $i;unwrap-double $i;DCMPG]
-
- [deg//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
- [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+(do-template [<eq> <lt> <unwrap> <cmp>]
+ [(do-template [<name> <reference>]
+ [(def: (<name> [subjectI paramI])
+ Binary
+ (|>. subjectI <unwrap>
+ paramI <unwrap>
+ <cmp>
+ ($i;int <reference>)
+ (predicateI $i;IF_ICMPEQ)))]
+ [<eq> 0]
+ [<lt> -1])]
+
+ [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
+ [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP]
+ [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG]
+ [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)]
)
(do-template [<name> <prepare> <transform>]
@@ -324,25 +301,25 @@
(|>. inputI <prepare> <transform>))]
[nat//to-int id id]
- [nat//to-char $i;unwrap-long
+ [nat//to-char ($i;unwrap #$;Long)
(<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)
$i;I2C $i;L2I)]
[int//to-nat id id]
- [int//to-real $i;unwrap-long (<| $i;wrap-double $i;L2D)]
+ [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)]
- [real//to-int $i;unwrap-double (<| $i;wrap-long $i;D2L)]
- [real//to-deg $i;unwrap-double
- (<| $i;wrap-long ($i;INVOKESTATIC &runtime;runtime-name "real-to-deg"
- ($t;method (list $t;double) (#;Some $t;long) (list)) false))]
- [real//encode $i;unwrap-double
+ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
+ [frac//to-deg ($i;unwrap #$;Double)
+ (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "frac_to_deg"
+ ($t;method (list $t;double) (#;Some $t;long) (list)) false))]
+ [frac//encode ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)]
- [real//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC &runtime;runtime-name "decode_real" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
+ [frac//decode ($i;CHECKCAST "java.lang.String")
+ ($i;INVOKESTATIC &runtime;runtime-name "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
- [deg//to-real $i;unwrap-long
- (<| $i;wrap-double ($i;INVOKESTATIC &runtime;runtime-name "deg-to-real"
- ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
+ [deg//to-frac ($i;unwrap #$;Long)
+ (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-name "deg_to_frac"
+ ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
)
## [[Text]]
@@ -370,7 +347,7 @@
[text//eq id id
($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean]
+ ($i;wrap #$;Boolean)]
[text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false)
(predicateI $i;IF_ICMPEQ)]
@@ -379,7 +356,7 @@
id]
[text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean]
+ ($i;wrap #$;Boolean)]
[text//char ($i;CHECKCAST "java.lang.String") jvm-intI
($i;INVOKESTATIC &runtime;runtime-name "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
lux-intI]
@@ -414,11 +391,11 @@
($i;int -1)
($i;IF_ICMPEQ @not-found)
lux-intI
- make-someI
+ &runtime;someI
($i;GOTO @end)
($i;label @not-found)
$i;POP
- make-noneI
+ &runtime;noneI
($i;label @end))))]
[text//index "indexOf"]
@@ -433,9 +410,9 @@
[(def: (<name> inputI)
Unary
(|>. inputI
- $i;unwrap-double
+ ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false)
- $i;wrap-double))]
+ ($i;wrap #$;Double)))]
[math//cos "cos"]
[math//sin "sin"]
@@ -457,10 +434,10 @@
(do-template [<name> <method>]
[(def: (<name> [inputI paramI])
Binary
- (|>. inputI $i;unwrap-double
- paramI $i;unwrap-double
+ (|>. inputI ($i;unwrap #$;Double)
+ paramI ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false)
- $i;wrap-double))]
+ ($i;wrap #$;Double)))]
[math//atan2 "atan2"]
[math//pow "pow"]
@@ -469,10 +446,10 @@
(def: (math//round inputI)
Unary
(|>. inputI
- $i;unwrap-double
+ ($i;unwrap #$;Double)
($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false)
$i;L2D
- $i;wrap-double))
+ ($i;wrap #$;Double)))
## [[IO]]
(def: string-method $;Method ($t;method (list $String) #;None (list)))
@@ -502,7 +479,7 @@
(def: (io//current-time [])
Nullary
(|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false)
- $i;wrap-long))
+ ($i;wrap #$;Long)))
## [[Atoms]]
(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
@@ -526,7 +503,7 @@
oldI
newI
($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false)
- $i;wrap-boolean))
+ ($i;wrap #$;Boolean)))
## [[Processes]]
(def: (process//concurrency-level [])
@@ -542,7 +519,7 @@
(def: (process//schedule [millisecondsI procedureI])
Binary
- (|>. millisecondsI $i;unwrap-long
+ (|>. millisecondsI ($i;unwrap #$;Long)
procedureI ($i;CHECKCAST &runtime;function-name)
($i;INVOKESTATIC &runtime;runtime-name "schedule"
($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
@@ -594,28 +571,7 @@
(install "int min" (nullary int//min))
(install "int max" (nullary int//max))
(install "int to-nat" (unary int//to-nat))
- (install "int to-real" (unary int//to-real))))
-
-(def: real-procs
- Bundle
- (|> (D;new text;Hash<Text>)
- (install "real +" (binary real//add))
- (install "real -" (binary real//sub))
- (install "real *" (binary real//mul))
- (install "real /" (binary real//div))
- (install "real %" (binary real//rem))
- (install "real =" (binary real//eq))
- (install "real <" (binary real//lt))
- (install "real smallest" (nullary real//smallest))
- (install "real min" (nullary real//min))
- (install "real max" (nullary real//max))
- (install "real not-a-number" (nullary real//not-a-number))
- (install "real positive-infinity" (nullary real//positive-infinity))
- (install "real negative-infinity" (nullary real//negative-infinity))
- (install "real to-deg" (unary real//to-deg))
- (install "real to-int" (unary real//to-int))
- (install "real encode" (unary real//encode))
- (install "real decode" (unary real//decode))))
+ (install "int to-frac" (unary int//to-frac))))
(def: deg-procs
Bundle
@@ -631,17 +587,28 @@
(install "deg reciprocal" (binary deg//reciprocal))
(install "deg min" (nullary deg//min))
(install "deg max" (nullary deg//max))
- (install "deg to-real" (unary deg//to-real))))
+ (install "deg to-frac" (unary deg//to-frac))))
-(def: array-procs
+(def: frac-procs
Bundle
(|> (D;new text;Hash<Text>)
- (install "array new" (unary array//new))
- (install "array get" (binary array//get))
- (install "array put" (trinary array//put))
- (install "array remove" (binary array//remove))
- (install "array size" (unary array//size))
- ))
+ (install "frac +" (binary frac//add))
+ (install "frac -" (binary frac//sub))
+ (install "frac *" (binary frac//mul))
+ (install "frac /" (binary frac//div))
+ (install "frac %" (binary frac//rem))
+ (install "frac =" (binary frac//eq))
+ (install "frac <" (binary frac//lt))
+ (install "frac smallest" (nullary frac//smallest))
+ (install "frac min" (nullary frac//min))
+ (install "frac max" (nullary frac//max))
+ (install "frac not-a-number" (nullary frac//not-a-number))
+ (install "frac positive-infinity" (nullary frac//positive-infinity))
+ (install "frac negative-infinity" (nullary frac//negative-infinity))
+ (install "frac to-deg" (unary frac//to-deg))
+ (install "frac to-int" (unary frac//to-int))
+ (install "frac encode" (unary frac//encode))
+ (install "frac decode" (unary frac//decode))))
(def: text-procs
Bundle
@@ -657,6 +624,16 @@
(install "text clip" (trinary text//clip))
))
+(def: array-procs
+ Bundle
+ (|> (D;new text;Hash<Text>)
+ (install "array new" (unary array//new))
+ (install "array get" (binary array//get))
+ (install "array put" (trinary array//put))
+ (install "array remove" (binary array//remove))
+ (install "array size" (unary array//size))
+ ))
+
(def: math-procs
Bundle
(|> (D;new text;Hash<Text>)
@@ -711,7 +688,7 @@
(D;merge nat-procs)
(D;merge int-procs)
(D;merge deg-procs)
- (D;merge real-procs)
+ (D;merge frac-procs)
(D;merge text-procs)
(D;merge array-procs)
(D;merge math-procs)
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index e6a12d6fa..fe7a4b2cb 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -3,6 +3,7 @@
(lux (control monad)
(data ["R" result]
text/format)
+ [math]
[macro #+ Monad<Lux> "Lux/" Monad<Lux>]
[host #+ jvm-import do-to])
(luxc ["&" base]
@@ -44,6 +45,8 @@
(def: #export unit Text "\u0000")
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
+(def: $Object-Array $;Type ($t;array +1 $Object))
+(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: logI
$;Inst
@@ -52,9 +55,28 @@
(|>. outI ($i;string "LOG: ") (printI "print")
outI $i;SWAP (printI "println"))))
+(def: sum-method
+ $;Method
+ ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))
+
+(def: #export someI
+ $;Inst
+ (|>. ($i;int 1)
+ ($i;string "")
+ $i;DUP2_X1
+ $i;POP2
+ ($i;INVOKESTATIC runtime-name "sum_make" sum-method false)))
+
+(def: #export noneI
+ $;Inst
+ (|>. ($i;int 0)
+ $i;NULL
+ ($i;string unit)
+ ($i;INVOKESTATIC runtime-name "sum_make" sum-method false)))
+
(def: add-adt-methods
$;Def
- (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) $i;wrap-int $i;AASTORE)
+ (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE)
store-flag (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
store-value (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
(|>. ($d;method #$;Public $;staticM "sum_make"
@@ -159,7 +181,125 @@
$i;LRETURN))))
)))
-(def: init-method $;Method ($t;method (list) #;None (list)))
+(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0)))
+
+(def: add-frac-methods
+ $;Def
+ (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list))
+ (<| $i;with-label (function [@from])
+ $i;with-label (function [@to])
+ $i;with-label (function [@handler])
+ (|>. ($i;try @from @to @handler "java.lang.Exception")
+ ($i;label @from)
+ ($i;ALOAD +0)
+ ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false)
+ ($i;wrap #$;Double)
+ someI
+ $i;ARETURN
+ ($i;label @to)
+ ($i;label @handler)
+ noneI
+ $i;ARETURN)))
+ ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list))
+ (let [swap2 (|>. $i;DUP2_X2 $i;POP2)
+ drop-excessI (|>. ($i;double 1.0) $i;DREM)
+ shiftI (|>. frac-shiftI $i;DMUL)]
+ (|>. ($i;DLOAD +0)
+ ## Get upper half
+ drop-excessI
+ shiftI
+ ## Make a copy, so the lower half can be extracted
+ $i;DUP2
+ ## Get lower half
+ drop-excessI
+ shiftI
+ ## Turn it into a deg
+ $i;D2L
+ ## Turn the upper half into deg too
+ swap2
+ $i;D2L
+ ## Combine both pieces
+ $i;LADD
+ ## FINISH
+ $i;LRETURN
+ )))
+ ))
+
+(def: deg-bits Nat +64)
+(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)))
+(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list)))
+
+(def: add-deg-methods
+ $;Def
+ (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits.
+ low-half (|>. ($i;int -1) $i;I2L $i;LAND)
+ high-half (|>. ($i;int 32) $i;LUSHR)]
+ (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method
+ ## Based on: http://stackoverflow.com/a/31629280/6823464
+ (let [shift-downI (|>. ($i;int 32) $i;LUSHR)
+ low-leftI (|>. ($i;LLOAD +0) low-half)
+ high-leftI (|>. ($i;LLOAD +0) high-half)
+ low-rightI (|>. ($i;LLOAD +2) low-half)
+ high-rightI (|>. ($i;LLOAD +2) high-half)
+ bottomI (|>. low-leftI low-rightI $i;LMUL)
+ middleLI (|>. high-leftI low-rightI $i;LMUL)
+ middleRI (|>. low-leftI high-rightI $i;LMUL)
+ middleI (|>. middleLI middleRI $i;LADD)
+ topI (|>. high-leftI high-rightI $i;LMUL)]
+ (|>. bottomI shift-downI
+ middleI $i;LADD shift-downI
+ topI $i;LADD
+ $i;LRETURN)))
+ ($d;method #$;Public $;staticM "count_leading_zeros" clz-method
+ (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where)))
+ shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR))
+ decI (|>. ($i;int 1) $i;ISUB)]
+ (<| $i;with-label (function [@start])
+ $i;with-label (function [@done])
+ (|>. ($i;int 64)
+ ($i;label @start)
+ ($i;LLOAD +0) (when-zeroI @done)
+ ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0)
+ decI
+ ($i;GOTO @start)
+ ($i;label @done)
+ $i;IRETURN))))
+ ($d;method #$;Public $;staticM "div_deg" deg-method
+ (<| $i;with-label (function [@same])
+ (let [subjectI ($i;LLOAD +0)
+ paramI ($i;LLOAD +2)
+ equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
+ count-leading-zerosI ($i;INVOKESTATIC runtime-name "count_leading_zeros" clz-method false)
+ calc-max-shiftI (|>. subjectI count-leading-zerosI
+ paramI count-leading-zerosI
+ ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false)
+ ($i;ISTORE +4))
+ shiftI (|>. ($i;ILOAD +4) $i;LSHL)
+ imprecise-divisionI (|>. subjectI shiftI
+ paramI shiftI high-half
+ $i;LDIV)
+ scale-downI (|>. ($i;int 32) $i;LSHL)]
+ (|>. subjectI paramI
+ (equal?I @same)
+ ## Based on: http://stackoverflow.com/a/8510587/6823464
+ ## Shifting the operands as much as possible can help
+ ## avoid some loss of precision later.
+ calc-max-shiftI
+ imprecise-divisionI
+ scale-downI
+ $i;LRETURN
+ ($i;label @same)
+ ($i;long -1) ## ~= 1.0 Degrees
+ $i;LRETURN))))
+ ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list))
+ (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D)
+ lowI (|>. ($i;LLOAD +0) low-half $i;L2D)
+ scaleI (|>. frac-shiftI $i;DDIV)]
+ (|>. highI scaleI
+ lowI scaleI scaleI
+ $i;DADD
+ $i;DRETURN)))
+ )))
(def: #export generate
(Lux &common;Bytecode)
@@ -168,6 +308,7 @@
#let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list)
(|>. add-adt-methods
add-nat-methods
- ))]
+ add-frac-methods
+ add-deg-methods))]
_ (&common;store-class runtime-name bytecode)]
(wrap bytecode)))
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index e3a4bed75..8662aaa8d 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -1,7 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do])
(data text/format
(coll [list]))
[macro #+ Monad<Lux> "Lux/" Monad<Lux>]
@@ -28,13 +28,13 @@
(n.>= +2 size))
membersI (|> members
list;enumerate
- (mapM @ (function [[idx member]]
- (do @
- [memberI (generate member)]
- (wrap (|>. $i;DUP
- ($i;int (nat-to-int idx))
- memberI
- $i;AASTORE)))))
+ (monad;map @ (function [[idx member]]
+ (do @
+ [memberI (generate member)]
+ (wrap (|>. $i;DUP
+ ($i;int (nat-to-int idx))
+ memberI
+ $i;AASTORE)))))
(:: @ map $i;fuse))]
(wrap (|>. ($i;array $Object size) membersI))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 00:13:59 +0000