diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation')
4 files changed, 101 insertions, 89 deletions
diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux index c30f61225..be8b828cd 100644 --- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux @@ -111,7 +111,6 @@ (do macro;Monad<Meta> [_ (moduleL;set-annotations annotations) current-module macro;current-module-name - #let [_ (log! (format "{translate-imports} " current-module))] imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations) (maybe;default (list)))] (case (s;run imports (p;some import)) diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux index f5830bf9e..77d43a0e5 100644 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -16,7 +16,18 @@ (translation [";T" common] [";T" runtime] [";T" reference]) - [";L" variable #+ Variable]))) + [";L" variable #+ Variable Register]))) + +(def: (constant? register changeS) + (-> Register ls;Synthesis Bool) + (case changeS + (^multi (^code ((~ [_ (#;Int var)]))) + (i.= (variableL;local register) + var)) + true + + _ + false)) (def: #export (translate-recur translate argsS) (-> (-> ls;Synthesis (Meta $;Inst)) @@ -24,23 +35,30 @@ (Meta $;Inst)) (do macro;Monad<Meta> [[@begin offset] hostL;anchor - argsI (monad;map @ (function [[register argS]] - (let [register' (|> register (n.+ offset))] - (: (Meta $;Inst) - (case argS - (^multi (^code ((~ [_ (#;Int var)]))) - (i.= (variableL;local register') - var)) - (wrap id) - - _ - (do @ - [argI (translate argS)] - (wrap (|>. argI - ($i;ASTORE register')))))))) - (list;zip2 (list;n.range +0 (n.dec (list;size argsS))) - argsS))] - (wrap (|>. ($i;fuse argsI) + #let [pairs (list;zip2 (list;n.range offset (|> (list;size argsS) n.dec (n.+ offset))) + argsS)] + ## It may look weird that first I compile the values separately, + ## and then I compile the stores/allocations. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't compile values + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## must be the case. + valuesI+ (monad;map @ (function [[register argS]] + (: (Meta $;Inst) + (if (constant? register argS) + (wrap id) + (translate argS)))) + pairs) + #let [storesI+ (list/map (function [[register argS]] + (: $;Inst + (if (constant? register argS) + id + ($i;ASTORE register)))) + (list;reverse pairs))]] + (wrap (|>. ($i;fuse valuesI+) + ($i;fuse storesI+) ($i;GOTO @begin))))) (def: #export (translate-loop translate offset initsS+ bodyS) @@ -50,12 +68,12 @@ (do macro;Monad<Meta> [@begin $i;make-label initsI+ (monad;map @ translate initsS+) - bodyI (hostL;with-anchor [@begin (n.inc offset)] + bodyI (hostL;with-anchor [@begin offset] (translate bodyS)) #let [initializationI (|> (list;enumerate initsI+) (list/map (function [[register initI]] (|>. initI - ($i;ASTORE (|> register n.inc (n.+ offset)))))) + ($i;ASTORE (n.+ offset register))))) $i;fuse)]] (wrap (|>. initializationI ($i;label @begin) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 0e17f99a6..6c1b18932 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -267,65 +267,61 @@ $;Method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) -(do-template [<name> <const> <wrapper>] +(do-template [<name> <const> <type>] [(def: (<name> _) Nullary - (|>. <const> <wrapper>))] + (|>. <const> ($i;wrap <type>)))] - [nat//min ($i;long 0) ($i;wrap #$;Long)] - [nat//max ($i;long -1) ($i;wrap #$;Long)] + [nat//min ($i;long 0) #$;Long] + [nat//max ($i;long -1) #$;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) #$;Long] + [int//max ($i;long Long.MAX_VALUE) #$;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)] + [frac//smallest ($i;double Double.MIN_VALUE) #$;Double] + [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) #$;Double] + [frac//max ($i;double Double.MAX_VALUE) #$;Double] + [frac//not-a-number ($i;double Double.NaN) #$;Double] + [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) #$;Double] + [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) #$;Double] + + [deg//min ($i;long 0) #$;Long] + [deg//max ($i;long -1) #$;Long] ) -(do-template [<name> <unwrap> <wrap> <op>] +(do-template [<name> <type> <op>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <unwrap> - paramI <unwrap> + (|>. subjectI ($i;unwrap <type>) + paramI ($i;unwrap <type>) <op> - <wrap>))] + ($i;wrap <type>)))] - [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 #$;Long $i;LADD] + [int//sub #$;Long $i;LSUB] + [int//mul #$;Long $i;LMUL] + [int//div #$;Long $i;LDIV] + [int//rem #$;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) - ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] - [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($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] - [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) - ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] - [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($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] + [nat//add #$;Long $i;LADD] + [nat//sub #$;Long $i;LSUB] + [nat//mul #$;Long $i;LMUL] + [nat//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] + [nat//rem #$;Long ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] + + [frac//add #$;Double $i;DADD] + [frac//sub #$;Double $i;DSUB] + [frac//mul #$;Double $i;DMUL] + [frac//div #$;Double $i;DDIV] + [frac//rem #$;Double $i;DREM] + + [deg//add #$;Long $i;LADD] + [deg//sub #$;Long $i;LSUB] + [deg//mul #$;Long ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] + [deg//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] + [deg//rem #$;Long $i;LSUB] + [deg//scale #$;Long $i;LMUL] + [deg//reciprocal #$;Long $i;LDIV] ) (do-template [<eq> <lt> <unwrap> <cmp>] @@ -382,11 +378,11 @@ ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false) <post>))] - [text//size "java.lang.String" "length" lux-intI $t;int] - [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] - [text//trim "java.lang.String" "trim" id $String] - [text//upper-case "java.lang.String" "toUpperCase" id $String] - [text//lower-case "java.lang.String" "toLowerCase" id $String] + [text//size "java.lang.String" "length" lux-intI $t;int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] + [text//trim "java.lang.String" "trim" id $String] + [text//upper "java.lang.String" "toUpperCase" id $String] + [text//lower "java.lang.String" "toLowerCase" id $String] ) (do-template [<name> <pre-subject> <pre-param> <op> <post>] @@ -676,18 +672,21 @@ (def: text-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "text =" (binary text//eq)) - (install "text <" (binary text//lt)) - (install "text concat" (binary text//concat)) - (install "text index" (trinary text//index)) - (install "text size" (unary text//size)) - (install "text hash" (unary text//hash)) - (install "text replace-once" (trinary text//replace-once)) - (install "text replace-all" (trinary text//replace-all)) - (install "text char" (binary text//char)) - (install "text clip" (trinary text//clip)) - )) + (<| (prefix "text") + (|> (dict;new text;Hash<Text>) + (install "=" (binary text//eq)) + (install "<" (binary text//lt)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary text//size)) + (install "hash" (unary text//hash)) + (install "replace-once" (trinary text//replace-once)) + (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary text//upper)) + (install "lower" (unary text//lower)) + ))) (def: array-procs Bundle diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index 87174b192..d2bb1645b 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -198,7 +198,6 @@ div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) 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 (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))) @@ -220,14 +219,12 @@ ($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))) @@ -257,7 +254,6 @@ ## 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))) |