From 65c182755954f64fd112284a5336ba05547a4283 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 3 Jul 2017 18:15:24 -0400 Subject: - Tested the compilation for "nat" procedures. - Expanded the runtime. - Some bug-fixes and refactorings. --- new-luxc/source/luxc/analyser/procedure/common.lux | 64 +++--- new-luxc/source/luxc/generator/host/jvm/def.lux | 26 ++- new-luxc/source/luxc/generator/host/jvm/inst.lux | 256 ++++++++++----------- .../source/luxc/generator/procedure/common.jvm.lux | 12 +- new-luxc/source/luxc/generator/runtime.jvm.lux | 118 +++++++++- new-luxc/source/luxc/host.jvm.lux | 27 +-- .../test/luxc/generator/procedure/common.jvm.lux | 127 ++++++++++ new-luxc/test/tests.lux | 7 +- 8 files changed, 436 insertions(+), 201 deletions(-) create mode 100644 new-luxc/test/test/luxc/generator/procedure/common.jvm.lux diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index e96874960..1976d266d 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -15,15 +15,15 @@ (analyser ["&;" common]))) ## [Utils] -(type: Proc-Analyser +(type: Proc (-> &;Analyser (List Code) (Lux Analysis))) -(type: Proc-Set - (D;Dict Text Proc-Analyser)) +(type: Bundle + (D;Dict Text Proc)) (def: (install name unnamed) - (-> Text (-> Text Proc-Analyser) - (-> Proc-Set Proc-Set)) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) (D;put name (unnamed name))) (def: (wrong-amount-error proc expected actual) @@ -33,7 +33,7 @@ " Actual: " (|> actual nat-to-int %i))) (def: (simple-proc proc input-types output-type) - (-> Text (List Type) Type Proc-Analyser) + (-> Text (List Type) Type Proc) (let [num-expected (list;size input-types)] (function [analyse args] (let [num-actual (list;size args)] @@ -51,29 +51,29 @@ (&;fail (wrong-amount-error proc num-expected num-actual))))))) (def: (binary-operation subjectT paramT outputT proc) - (-> Type Type Type Text Proc-Analyser) + (-> Type Type Type Text Proc) (simple-proc proc (list subjectT paramT) outputT)) (def: (trinary-operation subjectT param0T param1T outputT proc) - (-> Type Type Type Type Text Proc-Analyser) + (-> Type Type Type Type Text Proc) (simple-proc proc (list subjectT param0T param1T) outputT)) (def: (unary-operation inputT outputT proc) - (-> Type Type Text Proc-Analyser) + (-> Type Type Text Proc) (simple-proc proc (list inputT) outputT)) (def: (special-value valueT proc) - (-> Type Text Proc-Analyser) + (-> Type Text Proc) (simple-proc proc (list) valueT)) (def: (converter fromT toT proc) - (-> Type Type Text Proc-Analyser) + (-> Type Type Text Proc) (simple-proc proc (list fromT) toT)) ## [Analysers] ## "lux is" represents reference/pointer equality. (def: (analyse-lux-is proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -83,7 +83,7 @@ ## "lux try" provides a simple way to interact with the host platform's ## error-handling facilities. (def: (analyse-lux-try proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -103,13 +103,13 @@ (&;fail (wrong-amount-error proc +1 (list;size args)))))))) (def: lux-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "lux is" analyse-lux-is) (install "lux try" analyse-lux-try))) (def: io-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "io log" (converter Text Unit)) (install "io error" (converter Text Bottom)) @@ -117,7 +117,7 @@ (install "io current-time" (special-value Int)))) (def: bit-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "bit count" (unary-operation Nat Nat)) (install "bit and" (binary-operation Nat Nat Nat)) @@ -129,7 +129,7 @@ )) (def: nat-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "nat +" (binary-operation Nat Nat Nat)) (install "nat -" (binary-operation Nat Nat Nat)) @@ -144,7 +144,7 @@ (install "nat to-text" (converter Nat Text)))) (def: int-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "int +" (binary-operation Int Int Int)) (install "int -" (binary-operation Int Int Int)) @@ -159,7 +159,7 @@ (install "int to-real" (converter Int Real)))) (def: deg-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "deg +" (binary-operation Deg Deg Deg)) (install "deg -" (binary-operation Deg Deg Deg)) @@ -175,7 +175,7 @@ (install "deg to-real" (converter Deg Real)))) (def: real-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "real +" (binary-operation Real Real Real)) (install "real -" (binary-operation Real Real Real)) @@ -196,7 +196,7 @@ (install "real from-text" (converter Text (type (Maybe Real)))))) (def: text-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "text =" (binary-operation Text Text Bool)) (install "text <" (binary-operation Text Text Bool)) @@ -210,7 +210,7 @@ )) (def: (analyse-array-get proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -218,7 +218,7 @@ analyse args))))) (def: (analyse-array-put proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -226,7 +226,7 @@ analyse args))))) (def: (analyse-array-remove proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -234,7 +234,7 @@ analyse args))))) (def: array-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "array new" (unary-operation Nat Array)) (install "array get" analyse-array-get) @@ -244,7 +244,7 @@ )) (def: math-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "math cos" (unary-operation Real Real)) (install "math sin" (unary-operation Real Real)) @@ -267,7 +267,7 @@ )) (def: (analyse-atom-new proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -287,7 +287,7 @@ (&;fail (wrong-amount-error proc +1 (list;size args)))))))) (def: (analyse-atom-read proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -295,7 +295,7 @@ analyse args))))) (def: (analyse-atom-compare-and-swap proc) - (-> Text Proc-Analyser) + (-> Text Proc) (function [analyse args] (&common;with-var (function [[var-id varT]] @@ -303,7 +303,7 @@ analyse args))))) (def: atom-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "atom new" analyse-atom-new) (install "atom read" analyse-atom-read) @@ -311,7 +311,7 @@ )) (def: process-procs - Proc-Set + Bundle (|> (D;new text;Hash) (install "process concurrency-level" (special-value Nat)) (install "process future" (unary-operation (type (io;IO Top)) Unit)) @@ -319,7 +319,7 @@ )) (def: #export procedures - Proc-Set + Bundle (|> (D;new text;Hash) (D;merge lux-procs) (D;merge bit-procs) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index 6f0f97d9b..42cfa2d68 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -2,6 +2,7 @@ lux (lux (data [text] text/format + [product] (coll ["a" array] [list "L/" Functor])) [host #+ jvm-import do-to]) @@ -154,11 +155,11 @@ (visibility-flag visibility) (class-flag config)) - name + ($t;binary-name name) (parameters-signature parameters super interfaces) - (|> super class-to-type $t;descriptor) + (|> super product;left $t;binary-name) (|> interfaces - (L/map (|>. class-to-type $t;descriptor)) + (L/map (|>. product;left $t;binary-name)) string-array)])) definitions) _ (ClassWriter.visitEnd [] writer)] @@ -181,11 +182,11 @@ Opcodes.ACC_INTERFACE (visibility-flag visibility) (class-flag config)) - name + ($t;binary-name name) (parameters-signature parameters $Object interfaces) - (|> $Object class-to-type $t;descriptor) + (|> $Object product;left $t;binary-name) (|> interfaces - (L/map (|>. class-to-type $t;descriptor)) + (L/map (|>. product;left $t;binary-name)) string-array)])) definitions) _ (ClassWriter.visitEnd [] writer)] @@ -198,7 +199,7 @@ (let [=method (ClassWriter.visitMethod [($_ i.+ (visibility-flag visibility) (method-flag config)) - name + ($t;binary-name name) ($t;method-descriptor type) ($t;method-signature type) (exceptions-array type)] @@ -217,7 +218,7 @@ (visibility-flag visibility) (method-flag config) Opcodes.ACC_ABSTRACT) - name + ($t;binary-name name) ($t;method-descriptor type) ($t;method-signature type) (exceptions-array type)] @@ -231,7 +232,10 @@ (let [=field (do-to (ClassWriter.visitField [($_ i.+ (visibility-flag visibility) (field-flag config)) - name ($t;descriptor type) ($t;signature type) (host;null)] writer) + ($t;binary-name name) + ($t;descriptor type) + ($t;signature type) + (host;null)] writer) (FieldVisitor.visitEnd []))] writer))) @@ -242,7 +246,9 @@ (let [=field (do-to (ClassWriter.visitField [($_ i.+ (visibility-flag visibility) (field-flag config)) - name ($t;descriptor ) ($t;signature ) + ($t;binary-name name) + ($t;descriptor ) + ($t;signature ) ( value)] writer) (FieldVisitor.visitEnd []))] diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 824598ab8..30148c4e5 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -1,6 +1,13 @@ (;module: [lux #- char] - (lux [host #+ jvm-import do-to]) + (lux (control monad + ["p" parser]) + (data text/format + (coll [list "L/" Functor])) + [host #+ jvm-import do-to] + [macro] + (macro [code] + ["s" syntax #+ syntax:])) ["$" ..] (.. ["$t" type])) @@ -8,83 +15,85 @@ (jvm-import #long java.lang.Object) (jvm-import #long java.lang.String) -(jvm-import org.objectweb.asm.Opcodes - (#static T_BOOLEAN int) - (#static T_CHAR int) - (#static T_FLOAT int) - (#static T_DOUBLE int) - (#static T_BYTE int) - (#static T_SHORT int) - (#static T_INT int) - (#static T_LONG int) - - (#static CHECKCAST int) - (#static NEW int) - (#static NEWARRAY int) - (#static ANEWARRAY int) - - (#static DUP int) - (#static DUP2_X1 int) - (#static POP int) - (#static POP2 int) - - (#static IF_ICMPEQ int) - (#static IF_ACMPEQ int) - (#static IFNULL int) - (#static GOTO int) - - (#static ACONST_NULL int) - - (#static ILOAD int) - (#static ALOAD int) - - (#static IADD int) - - (#static LAND int) - (#static LOR int) - (#static LXOR int) - (#static LSHL int) - (#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) - - (#static I2L int) - (#static L2I int) - (#static L2D int) - (#static D2L int) - (#static I2C int) - - (#static AALOAD int) - (#static AASTORE int) - (#static ARRAYLENGTH int) - - (#static GETSTATIC int) - (#static PUTSTATIC int) - (#static GETFIELD int) - (#static PUTFIELD int) - - (#static INVOKESTATIC int) - (#static INVOKESPECIAL int) - (#static INVOKEVIRTUAL int) - - (#static ATHROW int) - - (#static RETURN int) - (#static ARETURN int) - ) +(syntax: (declare [codes (p;many s;local-symbol)]) + (|> codes + (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) + wrap)) + +(with-expansions [ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE + T_BYTE T_SHORT T_INT T_LONG) + (declare DUP DUP2_X1 + POP POP2 + SWAP) + (declare IF_ICMPEQ IF_ACMPEQ IFNULL + IFLT IFLE IFGT IFGE + GOTO)] + (jvm-import org.objectweb.asm.Opcodes + + + (#static CHECKCAST int) + (#static NEW int) + (#static NEWARRAY int) + (#static ANEWARRAY int) + + + + + (#static ACONST_NULL int) + + (#static ILOAD int) + (#static LLOAD int) + (#static ALOAD int) + + (#static IADD int) + + (#static LAND int) + (#static LOR int) + (#static LXOR int) + (#static LSHL int) + (#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) + + (#static I2L int) + (#static L2I int) + (#static L2D int) + (#static D2L int) + (#static I2C int) + + (#static AALOAD int) + (#static AASTORE int) + (#static ARRAYLENGTH int) + + (#static GETSTATIC int) + (#static PUTSTATIC int) + (#static GETFIELD int) + (#static PUTFIELD int) + + (#static INVOKESTATIC int) + (#static INVOKESPECIAL int) + (#static INVOKEVIRTUAL int) + + (#static ATHROW int) + + (#static RETURN int) + (#static IRETURN int) + (#static LRETURN int) + (#static ARETURN int) + )) (jvm-import org.objectweb.asm.FieldVisitor (visitEnd [] void)) @@ -126,57 +135,48 @@ [string Text id] ) -(do-template [ ] +(syntax: (prefix [base s;local-symbol]) + (wrap (list (code;local-symbol (format "Opcodes." base))))) + +(def: #export NULL + $;Inst + (function [visitor] + (do-to visitor + (MethodVisitor.visitInsn [(prefix ACONST_NULL)])))) + +(do-template [] [(def: #export $;Inst (function [visitor] (do-to visitor - (MethodVisitor.visitInsn []))))] + (MethodVisitor.visitInsn [(prefix )]))))] - [DUP Opcodes.DUP] - [DUP2_X1 Opcodes.DUP2_X1] - [POP Opcodes.POP] - [POP2 Opcodes.POP2] + ## Stack + [DUP] [DUP2_X1] [POP] [POP2] [SWAP] - [NULL Opcodes.ACONST_NULL] - - [IADD Opcodes.IADD] - - [LAND Opcodes.LAND] - [LOR Opcodes.LOR] - [LXOR Opcodes.LXOR] - [LSHL Opcodes.LSHL] - [LSHR Opcodes.LSHR] - [LUSHR Opcodes.LUSHR] - - [LADD Opcodes.LADD] - [LSUB Opcodes.LSUB] - [LMUL Opcodes.LMUL] - [LDIV Opcodes.LDIV] - [LREM Opcodes.LREM] - [LCMP Opcodes.LCMP] - - [DADD Opcodes.DADD] - [DSUB Opcodes.DSUB] - [DMUL Opcodes.DMUL] - [DDIV Opcodes.DDIV] - [DREM Opcodes.DREM] - [DCMPG Opcodes.DCMPG] - - [I2L Opcodes.I2L] - [L2I Opcodes.L2I] - [L2D Opcodes.L2D] - [D2L Opcodes.D2L] - [I2C Opcodes.I2C] - - [AALOAD Opcodes.AALOAD] - [AASTORE Opcodes.AASTORE] - [ARRAYLENGTH Opcodes.ARRAYLENGTH] + ## Integer arithmetic + [IADD] + + ## Long bitwise + [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR] - [ATHROW Opcodes.ATHROW] + ## Long arithmethic + [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP] - [RETURN Opcodes.RETURN] - [ARETURN Opcodes.ARETURN] + ## Double arithmetic + [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DCMPG] + + ## Conversions + [I2L] [L2I] [L2D] [D2L] [I2C] + + ## Array + [AALOAD] [AASTORE] [ARRAYLENGTH] + + ## Exceptions + [ATHROW] + + ## Return + [RETURN] [IRETURN] [LRETURN] [ARETURN] ) (do-template [ ] @@ -186,8 +186,9 @@ (do-to visitor (MethodVisitor.visitVarInsn [ (nat-to-int register)]))))] - [ALOAD Opcodes.ALOAD] [ILOAD Opcodes.ILOAD] + [LLOAD Opcodes.LLOAD] + [ALOAD Opcodes.ALOAD] ) (do-template [ ] @@ -242,17 +243,16 @@ [INVOKESPECIAL Opcodes.INVOKESPECIAL] ) -(do-template [ ] +(do-template [] [(def: #export ( @where) (-> $;Label $;Inst) (function [visitor] (do-to visitor - (MethodVisitor.visitJumpInsn [ @where]))))] + (MethodVisitor.visitJumpInsn [(prefix ) @where]))))] - [IF_ICMPEQ Opcodes.IF_ICMPEQ] - [IF_ACMPEQ Opcodes.IF_ACMPEQ] - [IFNULL Opcodes.IFNULL] - [GOTO Opcodes.GOTO] + [IF_ICMPEQ] [IF_ACMPEQ] [IFNULL] + [IFLT] [IFLE] [IFGT] [IFGE] + [GOTO] ) (def: #export (label @label) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index 957a2efa4..fcfba7682 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -172,7 +172,7 @@ (def: (bit//count inputI) Unary - (|>. inputI + (|>. inputI $i;unwrap-long ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false) lux-intI)) @@ -231,7 +231,7 @@ (def: deg-method $;Method nat-method) -(def: compare-unsigned-method +(def: compare-nat-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) @@ -305,8 +305,8 @@ ($i;int ) (predicateI $i;IF_ICMPEQ)))] - [nat//eq 0 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)] - [nat//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)] + [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] @@ -314,8 +314,8 @@ [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 "compareUnsigned" compare-unsigned-method false)] - [deg//lt -1 $i;unwrap-long ($i;INVOKESTATIC &runtime;runtime-name "compareUnsigned" compare-unsigned-method false)] + [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 [ ] diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 8c0b294c1..e6a12d6fa 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -39,20 +39,25 @@ (visitEnd [] void) (toByteArray [] Byte-Array)) -(def: #export runtime-name Text "LuxRT") +(def: #export runtime-name Text "LuxRuntime") (def: #export function-name Text "LuxFunction") (def: #export unit Text "\u0000") (def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: logI + $;Inst + (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] + (|>. outI ($i;string "LOG: ") (printI "print") + outI $i;SWAP (printI "println")))) + (def: add-adt-methods $;Def (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 true #$;finalM false #$;synchronizedM false} - "sum_make" + (|>. ($d;method #$;Public $;staticM "sum_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) (list)) @@ -62,16 +67,107 @@ store-value $i;ARETURN))))) +(def: add-nat-methods + $;Def + (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where))) + $BigInteger ($t;class "java.math.BigInteger" (list)) + upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) + div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) + upcastI ($i;INVOKESTATIC runtime-name "_toUnsignedBigInteger" upcast-method false) + downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method + (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) + discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) + prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR + upcastI + ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false)) + prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL + ($i;int 32) $i;LUSHR + upcastI)] + (<| $i;with-label (function [@simple]) + (|>. (discernI @simple) + ## else + prepare-upperI + prepare-lowerI + ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false) + $i;ARETURN + ## then + ($i;label @simple) + ($i;LLOAD +0) + upcastI + $i;ARETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + ($d;method #$;Public $;staticM "compare_nat" compare-nat-method + (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] + (|>. ($i;LLOAD +0) shiftI + ($i;LLOAD +2) shiftI + $i;LCMP + $i;IRETURN))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + ($d;method #$;Public $;staticM "div_nat" div-method + (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) + is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) + small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN) + big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@is-zero]) + $i;with-label (function [@param-is-large]) + $i;with-label (function [@subject-is-small]) + (|>. (is-param-largeI @param-is-large) + ## Param is not too large + (is-subject-smallI @subject-is-small) + ## Param is small, but subject is large + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-divisionI downcastI $i;LRETURN + ## Both param and subject are small, + ## and can thus be divided normally. + ($i;label @subject-is-small) + small-division + ## Param is too large. Cannot simply divide. + ## Depending on the result of the + ## comparison, a result will be determined. + ($i;label @param-is-large) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero) + ## Greater-than or equals + ($i;long 1) $i;LRETURN + ## Less than + ($i;label @is-zero) + ($i;long 0) $i;LRETURN)))) + ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + ($d;method #$;Public $;staticM "rem_nat" div-method + (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) + is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) + small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN) + big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)] + (<| $i;with-label (function [@large-number]) + $i;with-label (function [@subject-is-smaller-than-param]) + (|>. (is-subject-largeI @large-number) + (is-param-largeI @large-number) + small-remainderI + + ($i;label @large-number) + ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param) + + ($i;LLOAD +0) upcastI + ($i;LLOAD +2) upcastI + big-remainderI downcastI $i;LRETURN + + ($i;label @subject-is-smaller-than-param) + ($i;LLOAD +0) + $i;LRETURN)))) + ))) + +(def: init-method $;Method ($t;method (list) #;None (list))) + (def: #export generate (Lux &common;Bytecode) (do Monad [_ (wrap []) - #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) - (ClassWriter.visit [&common;bytecode-version - ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER) - runtime-name (host;null) - "java/lang/Object" (host;null)])) - add-adt-methods) - bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list) + (|>. add-adt-methods + add-nat-methods + ))] _ (&common;store-class runtime-name bytecode)] (wrap bytecode))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index 37b62b30d..d5b4e89b0 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -57,25 +57,26 @@ ClassLoader::defineClass)) (def: (fetch-byte-code class-name store) - (-> Text &&common;Class-Store &&common;Bytecode) - (|> store A;get io;run (d;get class-name) assume)) - -(def: (assume!! input) - (All [a] (-> (R;Result a) a)) - (case input - (#R;Success output) - output - - (#R;Error error) - (error! error))) + (-> Text &&common;Class-Store (Maybe &&common;Bytecode)) + (|> store A;get io;run (d;get class-name))) (def: (memory-class-loader store) (-> &&common;Class-Store ClassLoader) (object ClassLoader [] [] (ClassLoader (findClass [class-name String]) Class - (:!! (assume!! (define-class class-name (fetch-byte-code class-name store) (:! ClassLoader _jvm_this)))) - ))) + (case (fetch-byte-code class-name store) + (#;Some bytecode) + (case (define-class class-name bytecode (:! ClassLoader _jvm_this)) + (#R;Success class) + (:!! class) + + (#R;Error error) + (error! (format "Class definiton error: " class-name "\n" + error))) + + #;None + (error! (format "Class not found: " class-name)))))) (def: #export (init-host _) (-> Top &&common;Host) diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux new file mode 100644 index 000000000..96cf8ae97 --- /dev/null +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -0,0 +1,127 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data text/format + [bit] + ["R" result] + [bool "B/" Eq] + [text "T/" Eq] + [number "n/" Interval] + (coll ["a" array] + [list])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + [host #+ jvm-import] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" expr] + ["@;" eval] + ["@;" runtime] + ["@;" common])) + (test/luxc common)) + +(context: "Bit procedures" + [param r;nat + subject r;nat] + (with-expansions [ (do-template [ ] + [(test + (|> (@eval;eval (@;generate (#ls;Procedure + (list (#ls;Nat subject) + (#ls;Nat param))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= ( param subject) (:! Nat valueG)) + + _ + false)))] + + ["bit and" bit;and] + ["bit or" bit;or] + ["bit xor" bit;xor] + ["bit shift-left" bit;shift-left] + ["bit unsigned-shift-right" bit;unsigned-shift-right] + )] + ($_ seq + (test "bit count" + (|> (@eval;eval (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= (bit;count subject) (:! Nat valueG)) + + _ + false))) + + + (test "bit shift-right" + (|> (@eval;eval (@;generate (#ls;Procedure "bit shift-right" + (list (#ls;Int (nat-to-int subject)) + (#ls;Nat param))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (i.= (bit;shift-right param (nat-to-int subject)) + (:! Int valueG)) + + _ + false))) + ))) + +(context: "Nat procedures" + [param (|> r;nat (r;filter (|>. (n.= +0) not))) + subject r;nat] + (with-expansions [ (do-template [ ] + [(test + (|> (@eval;eval (@;generate (#ls;Procedure (list)))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= (:! Nat valueG)) + + _ + false)))] + + ["nat min" n/bottom] + ["nat max" n/top] + ) + (do-template [ ] + [(test + (|> (@eval;eval (@;generate (#ls;Procedure (list (#ls;Nat subject))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + ( ( subject) (:! valueG)) + + _ + false)))] + + ["nat to-int" Int nat-to-int i.=] + ["nat to-char" Text text;from-code T/=] + ) + (do-template [ ] + [(test + (|> (do Monad + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Procedure + (list (#ls;Nat subject) + (#ls;Nat param)))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + ( ( param subject) (:! valueG)) + + _ + false)))] + + ["nat +" n.+ Nat n.=] + ["nat -" n.- Nat n.=] + ["nat *" n.* Nat n.=] + ["nat /" n./ Nat n.=] + ["nat %" n.% Nat n.=] + ["nat =" n.= Bool B/=] + ["nat <" n.< Bool B/=] + )] + ($_ seq + + + + ))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 92644ff48..695c72174 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -20,7 +20,12 @@ ["_;S" procedure] ["_;S" loop]) (generator ["_;G" primitive] - ["_;G" structure])))) + ["_;G" structure] + (procedure ["_;G" common])) + )) + ## (luxc (generator ["_;G" function]) + ## ) + ) ## [Program] (program: args -- cgit v1.2.3