diff options
Diffstat (limited to 'new-luxc/source/luxc/generator')
| -rw-r--r-- | new-luxc/source/luxc/generator/case.jvm.lux | 63 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 34 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/function.jvm.lux | 19 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 132 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/primitive.jvm.lux | 9 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/common.jvm.lux | 41 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 7 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 104 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/structure.jvm.lux | 9 |
9 files changed, 244 insertions, 174 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index 53912f5d0..f20c83f6e 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -2,9 +2,9 @@ lux (lux (control [monad #+ do]) [meta "meta/" Monad<Meta>]) - (luxc (lang ["ls" synthesis]) - (generator [expr] - (host ["$" jvm] + (luxc [";L" host] + (lang ["ls" synthesis]) + (generator (host ["$" jvm] (jvm ["$t" type] ["$i" inst])))) [../runtime]) @@ -24,7 +24,7 @@ (def: peekI $;Inst (|>. $i;DUP - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "pm_peek" ($t;method (list ../runtime;$Stack) (#;Some $Object) @@ -33,7 +33,7 @@ (def: popI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-class + (|>. ($i;INVOKESTATIC hostL;runtime-class "pm_pop" ($t;method (list ../runtime;$Stack) (#;Some ../runtime;$Stack) @@ -42,19 +42,20 @@ (def: pushI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-class + (|>. ($i;INVOKESTATIC hostL;runtime-class "pm_push" ($t;method (list ../runtime;$Stack $Object) (#;Some ../runtime;$Stack) (list)) false))) -(def: (generate-pattern' stack-depth @else @end path) - (-> Nat $;Label $;Label ls;Path (Meta $;Inst)) +(def: (generate-pattern' generate stack-depth @else @end path) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat $;Label $;Label ls;Path (Meta $;Inst)) (case path (#ls;ExecP bodyS) (do meta;Monad<Meta> - [bodyI (expr;generate bodyS)] + [bodyI (generate bodyS)] (wrap (|>. (pop-altI stack-depth) bodyI ($i;GOTO @end)))) @@ -104,7 +105,7 @@ (#ls;TupleP idx subP) (do meta;Monad<Meta> - [subI (generate-pattern' stack-depth @else @end subP) + [subI (generate-pattern' generate stack-depth @else @end subP) #let [[idx tail?] (case idx (#;Left idx) [idx false] @@ -124,7 +125,7 @@ (|>. peekI ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class (if tail? "pm_right" "pm_left") ($t;method (list ../runtime;$Tuple $t;int) (#;Some $Object) @@ -135,7 +136,7 @@ (#ls;VariantP idx subP) (do meta;Monad<Meta> - [subI (generate-pattern' stack-depth @else @end subP) + [subI (generate-pattern' generate stack-depth @else @end subP) #let [[idx last?] (case idx (#;Left idx) [idx false] @@ -151,7 +152,7 @@ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) ($i;int (nat-to-int idx)) flagI - ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant" + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) (#;Some ../runtime;$Datum) (list)) @@ -168,16 +169,16 @@ (#ls;SeqP leftP rightP) (do meta;Monad<Meta> - [leftI (generate-pattern' stack-depth @else @end leftP) - rightI (generate-pattern' stack-depth @else @end rightP)] + [leftI (generate-pattern' generate stack-depth @else @end leftP) + rightI (generate-pattern' generate stack-depth @else @end rightP)] (wrap (|>. leftI rightI))) (#ls;AltP leftP rightP) (do meta;Monad<Meta> [@alt-else $i;make-label - leftI (generate-pattern' (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-pattern' stack-depth @else @end rightP)] + leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-pattern' generate stack-depth @else @end rightP)] (wrap (|>. $i;DUP leftI ($i;label @alt-else) @@ -185,30 +186,42 @@ rightI))) )) -(def: (generate-pattern path @end) - (-> ls;Path $;Label (Meta $;Inst)) +(def: (generate-pattern generate path @end) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Path $;Label (Meta $;Inst)) (do meta;Monad<Meta> [@else $i;make-label - pathI (generate-pattern' +1 @else @end path)] + pathI (generate-pattern' generate +1 @else @end path)] (wrap (|>. pathI ($i;label @else) $i;POP - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "pm_fail" ($t;method (list) #;None (list)) false) $i;NULL ($i;GOTO @end))))) -(def: #export (generate valueS path) - (-> ls;Synthesis ls;Path (Meta $;Inst)) +(def: #export (generate-case generate valueS path) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Synthesis ls;Path (Meta $;Inst)) (do meta;Monad<Meta> [@end $i;make-label - valueI (expr;generate valueS) - pathI (generate-pattern path @end)] + valueI (generate valueS) + pathI (generate-pattern generate path @end)] (wrap (|>. valueI $i;NULL $i;SWAP pushI pathI ($i;label @end))))) + +(def: #export (generate-let generate register inputS exprS) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) + (do meta;Monad<Meta> + [inputI (generate inputS) + exprI (generate exprS)] + (wrap (|>. inputI + ($i;ASTORE register) + exprI)))) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 116c29fb5..685bf2335 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["ex" exception #+ exception:]) (data text/format) [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) (luxc ["&" base] @@ -15,8 +16,11 @@ ["&;" procedure] ["&;" function] ["&;" reference] + [";G" case] (host ["$" jvm])))) +(exception: #export Unrecognized-Synthesis) + (def: #export (generate synthesis) (-> ls;Synthesis (Meta $;Inst)) (case synthesis @@ -47,6 +51,12 @@ (#ls;Definition definition) (&reference;generate-definition definition) + (#ls;Let register inputS exprS) + (caseG;generate-let generate register inputS exprS) + + (#ls;Case inputS pathPS) + (caseG;generate-case generate inputS pathPS) + (#ls;Function arity env body) (&function;generate-function generate env arity body) @@ -57,25 +67,5 @@ (&procedure;generate-procedure generate name args) _ - (meta;fail "Unrecognized synthesis.") + (&;throw Unrecognized-Synthesis "") )) - -## (def: #export (eval type code) -## (-> Type Code (Meta Top)) -## (do Monad<Meta> -## [analysis (&;with-expected-type leftT -## (&analyser;analyser eval code)) -## #let [synthesis (&synthesizer;synthesize analysis)] -## inst (generate synthesis)] -## (&eval;eval inst))) - -## (def: analyse -## &;Analyser -## (&analyser;analyser eval)) - -## (def: #export (generate input) -## (-> Code (Meta Unit)) -## (do Monad<Meta> -## [analysis (analyse input) -## #let [synthesis (&synthesizer;synthesize analysis)]] -## (generate-synthesis synthesis))) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux index 97d3a7c91..ce92b9010 100644 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -5,6 +5,7 @@ (coll [list "list/" Functor<List> Monoid<List>])) [meta]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -58,7 +59,7 @@ (def: get-amount-of-partialsI $;Inst (|>. ($i;ALOAD +0) - ($i;GETFIELD &runtime;function-class &runtime;partials-field $t;int))) + ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int))) (def: (load-fieldI class field) (-> Text Text $;Inst) @@ -77,9 +78,9 @@ later-applysI (if (n.> &runtime;num-apply-variants amount) (applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount)) id)] - (|>. ($i;CHECKCAST &runtime;function-class) + (|>. ($i;CHECKCAST hostL;function-class) (inputsI start max-args) - ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) + ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) later-applysI))) (def: (inc-intI by) @@ -167,9 +168,9 @@ (-> ls;Arity Nat $;Inst) (if (n.= +1 arity) (|>. ($i;int 0) - ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)) + ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)) (|>. ($i;ILOAD (n.inc env-size)) - ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)))) + ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)))) (def: (with-init class env arity) (-> Text (List ls;Variable) ls;Arity $;Def) @@ -262,7 +263,7 @@ ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) @default @labels) casesI - ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) + ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) $i;NULL $i;ARETURN )))) @@ -306,7 +307,7 @@ _ (&common;store-class function-class ($d;class #$;V1.6 #$;Public $;finalC function-class (list) - ($;simple-class &runtime;function-class) (list) + ($;simple-class hostL;function-class) (list) functionD))] (wrap instanceI))) @@ -326,9 +327,9 @@ argsI (monad;map @ generate argsS) #let [applyI (|> (segment &runtime;num-apply-variants argsI) (list/map (function [chunkI+] - (|>. ($i;CHECKCAST &runtime;function-class) + (|>. ($i;CHECKCAST hostL;function-class) ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) + ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) $i;fuse)]] (wrap (|>. functionI applyI)))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index f515e86ac..37ab75020 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -22,68 +22,72 @@ (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) wrap)) -(with-expansions [<conversion> (declare D2F D2I D2L - F2D F2I F2L - I2B I2C I2D I2F I2L I2S - L2D L2F L2I) - <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE - T_BYTE T_SHORT T_INT T_LONG) - <class> (declare CHECKCAST NEW INSTANCEOF) - <member> (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD - INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE) - <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2 - POP POP2 - SWAP) - <jump> (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL - IFEQ IFNE IFLT IFLE IFGT IFGE - GOTO) - <var> (declare ILOAD LLOAD DLOAD ALOAD - ISTORE LSTORE ASTORE) - <arithmetic> (declare IADD ISUB IMUL IDIV IREM - LADD LSUB LMUL LDIV LREM LCMP - FADD FSUB FMUL FDIV FREM FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DCMPG DCMPL) - <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR - LAND LOR LXOR LSHL LSHR LUSHR) - <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY - AALOAD AASTORE - BALOAD BASTORE - SALOAD SASTORE - IALOAD IASTORE - LALOAD LASTORE - FALOAD FASTORE - DALOAD DASTORE - CALOAD CASTORE) - <concurrency> (declare MONITORENTER MONITOREXIT) - <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)] - (host;import org.objectweb.asm.Opcodes - (#static NOP int) - - <conversion> - <primitive> - - <class> - - <stack> - <jump> - - (#static ACONST_NULL int) - - <var> - - <arithmetic> - <bit-wise> - - <array> - - <member> - - (#static ATHROW int) - - <concurrency> - - <return> - )) +(`` (host;import org.objectweb.asm.Opcodes + (#static NOP int) + + ## Conversion + (~~ (declare D2F D2I D2L + F2D F2I F2L + I2B I2C I2D I2F I2L I2S + L2D L2F L2I)) + + ## Primitive + (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE + T_BYTE T_SHORT T_INT T_LONG)) + + ## Class + (~~ (declare CHECKCAST NEW INSTANCEOF)) + + ## Stack + (~~ (declare DUP DUP_X1 DUP_X2 + DUP2 DUP2_X1 DUP2_X2 + POP POP2 + SWAP)) + + ## Jump + (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL + IFEQ IFNE IFLT IFLE IFGT IFGE + GOTO)) + + (#static ACONST_NULL int) + + ## Var + (~~ (declare ILOAD LLOAD DLOAD ALOAD + ISTORE LSTORE ASTORE)) + + ## Arithmetic + (~~ (declare IADD ISUB IMUL IDIV IREM + LADD LSUB LMUL LDIV LREM LCMP + FADD FSUB FMUL FDIV FREM FCMPG FCMPL + DADD DSUB DMUL DDIV DREM DCMPG DCMPL)) + + ## Bit-wise + (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR + LAND LOR LXOR LSHL LSHR LUSHR)) + + ## Array + (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY + AALOAD AASTORE + BALOAD BASTORE + SALOAD SASTORE + IALOAD IASTORE + LALOAD LASTORE + FALOAD FASTORE + DALOAD DASTORE + CALOAD CASTORE)) + + ## Member + (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD + INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)) + + (#static ATHROW int) + + ## Concurrency + (~~ (declare MONITORENTER MONITOREXIT)) + + ## Return + (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) + )) (host;import org.objectweb.asm.FieldVisitor (visitEnd [] void)) @@ -152,7 +156,9 @@ [NOP] ## Stack - [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP] + [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2] + [POP] [POP2] + [SWAP] ## Conversions [D2F] [D2I] [D2L] diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux index fc6ffae1f..571ba4835 100644 --- a/new-luxc/source/luxc/generator/primitive.jvm.lux +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -2,8 +2,9 @@ lux (lux (control monad) (data text/format) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) + [meta "meta/" Monad<Meta>]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -16,18 +17,18 @@ (def: #export generate-unit (Meta $;Inst) - (Meta/wrap ($i;string ../runtime;unit))) + (meta/wrap ($i;string hostL;unit))) (def: #export (generate-bool value) (-> Bool (Meta $;Inst)) - (Meta/wrap ($i;GETSTATIC "java.lang.Boolean" + (meta/wrap ($i;GETSTATIC "java.lang.Boolean" (if value "TRUE" "FALSE") ($t;class "java.lang.Boolean" (list))))) (do-template [<name> <type> <load> <wrap>] [(def: #export (<name> value) (-> <type> (Meta $;Inst)) - (Meta/wrap (|>. (<load> value) <wrap>)))] + (meta/wrap (|>. (<load> value) <wrap>)))] [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] [generate-int Int $i;long ($i;wrap #$;Long)] diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index 48a820663..fd76082a6 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -10,6 +10,7 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -56,7 +57,7 @@ (def: $Object-Array $;Type ($t;array +1 $Object)) (def: $String $;Type ($t;class "java.lang.String" (list))) (def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) -(def: $Function $;Type ($t;class &runtime;function-class (list))) +(def: $Function $;Type ($t;class hostL;function-class (list))) (def: #export (install name unnamed) (-> Text (-> Text Proc) @@ -142,8 +143,8 @@ (def: (lux//try riskyI) Unary (|>. riskyI - ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false))) + ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) ## [[Bits]] (do-template [<name> <op>] @@ -263,9 +264,9 @@ [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-class "div_nat" nat-method false)] + ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "rem_nat" nat-method false)] + ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] @@ -276,9 +277,9 @@ [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-class "mul_deg" deg-method false)] + ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "div_deg" deg-method false)] + ($i;INVOKESTATIC hostL;runtime-class "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] @@ -296,10 +297,10 @@ [<eq> 0] [<lt> -1])] - [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "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-class "compare_nat" compare-nat-method false)] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] ) (do-template [<name> <prepare> <transform>] @@ -317,15 +318,15 @@ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] [frac//to-deg ($i;unwrap #$;Double) - (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg" + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "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)] [frac//decode ($i;CHECKCAST "java.lang.String") - ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] [deg//to-frac ($i;unwrap #$;Long) - (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac" + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) false))] ) @@ -365,7 +366,7 @@ ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) ($i;wrap #$;Boolean)] [text//char ($i;CHECKCAST "java.lang.String") jvm-intI - ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) lux-intI] ) @@ -378,7 +379,7 @@ <op>))] [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC &runtime;runtime-class "text_clip" + ($i;INVOKESTATIC hostL;runtime-class "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] @@ -466,7 +467,7 @@ messageI ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - ($i;string &runtime;unit))) + ($i;string hostL;unit))) (def: (io//error messageI) Unary @@ -515,20 +516,20 @@ ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int) + (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) lux-intI)) (def: (process//future procedureI) Unary - (|>. procedureI ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "future" + (|>. procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "future" ($t;method (list $Function) (#;Some $Object) (list)) false))) (def: (process//schedule [millisecondsI procedureI]) Binary (|>. millisecondsI ($i;unwrap #$;Long) - procedureI ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "schedule" + procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "schedule" ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) ## [Bundles] diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index f908c6c6e..fc6bdd01b 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -15,6 +15,7 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -494,13 +495,13 @@ (wrap (|>. valueI ($i;unwrap primitive) ($i;PUTSTATIC class field (#$;Primitive primitive)) - ($i;string &runtime;unit)))) + ($i;string hostL;unit)))) #;None (wrap (|>. valueI ($i;CHECKCAST class) ($i;PUTSTATIC class field ($t;class class (list))) - ($i;string &runtime;unit))))) + ($i;string hostL;unit))))) _ (&;fail (format "Wrong syntax for '" proc "'.")))) @@ -655,7 +656,7 @@ (case returnT #;None (|>. returnI - ($i;string &runtime;unit)) + ($i;string hostL;unit)) (#;Some type) (case type diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index d2ad42a2c..d3f99ae6a 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -7,6 +7,7 @@ [meta] [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -40,20 +41,16 @@ (visitEnd [] void) (toByteArray [] (Array byte))) -(def: #export runtime-class Text "LuxRuntime") -(def: #export function-class Text "LuxFunction") -(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: #export $Stack $;Type ($t;array +1 $Object)) -(def: #export $Tuple $;Type ($t;array +1 $Object)) -(def: #export $Variant $;Type ($t;array +1 $Object)) +(def: #export $Tuple $;Type $Object-Array) +(def: #export $Variant $;Type $Object-Array) (def: #export $Tag $;Type $t;int) (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) -(def: #export $Function $;Type ($t;class function-class (list))) +(def: #export $Function $;Type ($t;class hostL;function-class (list))) (def: $Throwable $;Type ($t;class "java.lang.Throwable" (list))) (def: #export logI @@ -69,7 +66,7 @@ (def: variantI $;Inst - ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) + ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) (def: #export leftI $;Inst @@ -93,9 +90,13 @@ $;Inst (|>. ($i;int 0) $i;NULL - ($i;string unit) + ($i;string hostL;unit) variantI)) +(def: #export string-concatI + $;Inst + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + (def: #export partials-field Text "partials") (def: #export apply-method Text "apply") (def: #export num-apply-variants Nat +8) @@ -108,8 +109,59 @@ $;Def (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) - store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)] - (|>. ($d;method #$;Public $;staticM "variant_make" + store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE) + force-textMT ($t;method (list $Object) (#;Some $String) (list))] + (|>. ($d;method #$;Public $;staticM "force_text" force-textMT + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@normal-object]) + $i;with-label (function [@array-loop]) + $i;with-label (function [@within-bounds]) + $i;with-label (function [@is-first]) + $i;with-label (function [@elem-end]) + $i;with-label (function [@fold-end]) + (let [on-normal-objectI (|>. ($i;ALOAD +0) + ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false)) + on-null-objectI ($i;string "NULL") + arrayI (|>. ($i;ALOAD +0) + ($i;CHECKCAST ($t;descriptor $Object-Array))) + recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false) + force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI) + swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y + $i;POP2 ## Y,X,Y => Y,X + ) + add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI) + merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI + swap2 ## TPSI => SITP + string-concatI ## SITP => SIT + $i;DUP_X2 $i;POP ## SIT => TSI + ) + foldI (|>. $i;DUP ## TSI => TSII + ($i;IFEQ @is-first) ## TSI + force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end) + ($i;label @is-first) ## TSI + force-elemI merge-with-totalI + ($i;label @elem-end) ## TSI + ) + inc-idxI (|>. ($i;int 1) $i;IADD) + on-array-objectI (|>. ($i;string "[") ## T + arrayI $i;ARRAYLENGTH ## TS + ($i;int 0) ## TSI + ($i;label @array-loop) ## TSI + $i;DUP2 + ($i;IF_ICMPGT @within-bounds) ## TSI + $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end) + ($i;label @within-bounds) + foldI inc-idxI ($i;GOTO @array-loop) + ($i;label @fold-end))]) + (|>. ($i;ALOAD +0) + ($i;IFNULL @is-null) + ($i;ALOAD +0) + ($i;INSTANCEOF ($t;descriptor $Object-Array)) + ($i;IFEQ @normal-object) + on-array-objectI $i;ARETURN + ($i;label @normal-object) on-normal-objectI $i;ARETURN + ($i;label @is-null) on-null-objectI $i;ARETURN))) + ($d;method #$;Public $;staticM "variant_make" ($t;method (list $t;int $Object $Object) (#;Some $Variant) (list)) @@ -120,14 +172,18 @@ store-valueI $i;ARETURN))))) +(def: #export force-textI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + (def: 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-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "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-class "_toUnsignedBigInteger" upcast-method false) + upcastI ($i;INVOKESTATIC hostL;runtime-class "_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 @@ -300,7 +356,7 @@ (let [subjectI ($i;LLOAD +0) paramI ($i;LLOAD +2) equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC runtime-class "count_leading_zeros" clz-method false) + count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "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) @@ -373,7 +429,7 @@ ($i;int 1) $i;AALOAD $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list)) + ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list)) (<| $i;with-label (function [@begin]) $i;with-label (function [@just-return]) $i;with-label (function [@then]) @@ -487,7 +543,7 @@ ($i;label @from) ($i;ALOAD +0) $i;NULL - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) rightI $i;ARETURN ($i;label @to) @@ -505,14 +561,14 @@ (Meta &common;Bytecode) (do meta;Monad<Meta> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) (|>. adt-methods nat-methods frac-methods deg-methods pm-methods io-methods))] - _ (&common;store-class runtime-class bytecode)] + _ (&common;store-class hostL;runtime-class bytecode)] (wrap bytecode))) (def: generate-function @@ -526,24 +582,24 @@ (list/map $i;ALOAD) $i;fuse)] (|>. preI - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false) - ($i;CHECKCAST function-class) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST hostL;function-class) ($i;ALOAD arity) - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) $i;ARETURN))))) (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))) $d;fuse) - bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list) (|>. ($d;field #$;Public $;finalF partials-field $t;int) ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list)) (|>. ($i;ALOAD +0) ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false) ($i;ALOAD +0) ($i;ILOAD +1) - ($i;PUTFIELD function-class partials-field $t;int) + ($i;PUTFIELD hostL;function-class partials-field $t;int) $i;RETURN)) applyI))] - _ (&common;store-class function-class bytecode)] + _ (&common;store-class hostL;function-class bytecode)] (wrap bytecode))) (def: #export generate diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index cee5800cd..28196b914 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -3,9 +3,10 @@ (lux (control [monad #+ do]) (data text/format (coll [list])) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>] + [meta] [host #+ do-to]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -21,7 +22,7 @@ (def: #export (generate-tuple generate members) (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) - (do Monad<Meta> + (do meta;Monad<Meta> [#let [size (list;size members)] _ (&;assert "Cannot generate tuples with less than 2 elements." (n.>= +2 size)) @@ -47,12 +48,12 @@ (def: #export (generate-variant generate tag tail? member) (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) - (do Monad<Meta> + (do meta;Monad<Meta> [memberI (generate member)] (wrap (|>. ($i;int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "variant_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) |