diff options
Diffstat (limited to '')
5 files changed, 158 insertions, 124 deletions
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 33f74795a..fbecf2da5 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -7,10 +7,10 @@ (data ["e" error] [text "text/" Hash<Text>] text/format - (coll [list] + (coll [list "list/" Functor<List>] [dict])) [macro] - (lang [syntax] + (lang [syntax #+ Aliases] (type ["tc" check])) [host] [io #+ IO Process io] @@ -52,9 +52,12 @@ (wrap [annsI (:! Code annsV)]))) (def: (switch-compiler new-compiler) - (-> Compiler (Meta Unit)) + (-> Compiler (Meta Aliases)) (function [old-compiler] - (#e;Success [new-compiler []]))) + ((do macro;Monad<Meta> + [this macro;current-module] + (wrap (|> this (get@ #;module-aliases) (dict;from-list text;Hash<Text>) (: Aliases)))) + new-compiler))) (def: (ensure-valid-alias def-name annotations value) (-> Text Code Code (Meta Unit)) @@ -66,8 +69,8 @@ _ (&;throw Invalid-Alias def-name))) -(def: (translate translate-module code) - (-> (-> Text Compiler (Process Compiler)) Code (Meta Unit)) +(def: (translate translate-module aliases code) + (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases)) (case code (^code ((~ [_ (#;Symbol macro-name)]) (~@ args))) (do macro;Monad<Meta> @@ -76,15 +79,26 @@ (case ?macro (#;Some macro) (do @ - [expansion (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) + [expansion (: (Meta (List Code)) + (function [compiler] + (case (macroL;expand macro args compiler) + (#e;Error error) + ((&;throw Macro-Expansion-Failed error) compiler) - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler))) - _ (monad;map @ (translate translate-module) expansion)] - (wrap [])) + output + output))) + expansion-aliases (monad;map @ (translate translate-module aliases) expansion)] + (if (dict;empty? aliases) + (loop [expansion-aliases expansion-aliases] + (case expansion-aliases + #;Nil + (wrap aliases) + + (#;Cons head tail) + (if (dict;empty? head) + (recur tail) + (wrap head)))) + (wrap aliases))) #;None (&;throw Unrecognized-Statement (%code code)))) @@ -100,7 +114,7 @@ [_ (ensure-valid-alias def-name annsV valueC) _ (&;with-scope (statementT;translate-def def-name Void id annsI annsV))] - (wrap [])) + (wrap aliases)) #;None (do @ @@ -114,10 +128,15 @@ (analyse valueC)))) valueT (&;with-type-env (tc;clean valueT)) + ## #let [_ (if (or (text/= "list/size" def-name)) + ## (log! (format "{" def-name "}\n" + ## " ANALYSIS: " (%code valueA) "\n" + ## "SYNTHESIS: " (%code (expressionS;synthesize valueA)))) + ## [])] valueI (expressionT;translate (expressionS;synthesize valueA)) _ (&;with-scope (statementT;translate-def def-name valueT valueI annsI annsV))] - (wrap [])))))) + (wrap aliases)))))) (^code ("lux module" (~ annsC))) (do macro;Monad<Meta> @@ -135,23 +154,24 @@ [[_ programA] (&;with-scope (&;with-type (type (io;IO Unit)) (analyse programC))) - programI (expressionT;translate (expressionS;synthesize programA))] - (statementT;translate-program program-args programI)) + programI (expressionT;translate (expressionS;synthesize programA)) + _ (statementT;translate-program program-args programI)] + (wrap aliases)) _ (&;throw Unrecognized-Statement (%code code)))) -(def: (exhaust action) - (All [a] (-> (Meta a) (Meta Unit))) +(def: (forgive-eof action) + (-> (Meta Unit) (Meta Unit)) (function [compiler] (case (action compiler) - (#e;Success [compiler' _]) - ((exhaust action) compiler') - (#e;Error error) (if (ex;match? syntax;End-Of-File error) (#e;Success [compiler []]) - (#e;Error error))))) + (#e;Error error)) + + output + output))) (def: prelude Text "lux") @@ -164,10 +184,10 @@ _ (moduleL;flag-compiled! module-name)] (wrap output))) -(def: (read current-module) - (-> Text (Meta Code)) +(def: (read current-module aliases) + (-> Text Aliases (Meta Code)) (function [compiler] - (case (syntax;read current-module (get@ #;source compiler)) + (case (syntax;read current-module aliases (get@ #;source compiler)) (#e;Error error) (#e;Error error) @@ -178,8 +198,7 @@ (def: (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) (do io;Monad<Process> - [#let [_ (log! (format "{translate-module} " module-name))] - ## _ (&io;prepare-module target-dir module-name) + [## _ (&io;prepare-module target-dir module-name) [file-name file-content] (&io;read-module source-dirs module-name) #let [module-hash (text/hash file-content) translate-module (translate-module source-dirs target-dir)]] @@ -190,12 +209,15 @@ (with-active-compilation [module-name file-name file-content] - (exhaust - (do @ - [code (read module-name) - #let [[cursor _] code]] - (&;with-cursor cursor - (translate translate-module code)))))))] + (forgive-eof + (loop [aliases (: Aliases + (dict;new text;Hash<Text>))] + (do @ + [code (read module-name aliases) + #let [[cursor _] code] + aliases' (&;with-cursor cursor + (translate translate-module aliases code))] + (forgive-eof (recur aliases'))))))))] (wrap artifacts))) (#e;Success [compiler artifacts]) (do @ 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))) |