diff options
| author | Eduardo Julian | 2017-09-05 18:36:09 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2017-09-05 18:36:09 -0400 |
| commit | 50cc5fbe7cc8abde05085944393fcec4c791402f (patch) | |
| tree | da706b648b3bb5e0485475a81d5b4da242aa04f5 /new-luxc/source/luxc | |
| parent | 3add4d6996591897020236b5581f6ca21d4c2af8 (diff) | |
- Updated new compiler's code to the recent changes in the language.
- WIP: Some other changes/additions to the new compiler.
Diffstat (limited to 'new-luxc/source/luxc')
24 files changed, 492 insertions, 361 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 6f9eda064..a7e420eec 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -52,7 +52,7 @@ [#;Nat &&primitive;analyse-nat] [#;Int &&primitive;analyse-int] [#;Deg &&primitive;analyse-deg] - [#;Real &&primitive;analyse-real] + [#;Frac &&primitive;analyse-frac] [#;Text &&primitive;analyse-text]) (^ (#;Tuple (list))) diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 30d0a2b7a..0f5b4da4e 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] eq) (data [bool "B/" Eq<Bool>] [number] @@ -102,7 +102,7 @@ [Nat #;Nat #la;NatP] [Int #;Int #la;IntP] [Deg #;Deg #la;DegP] - [Real #;Real #la;RealP] + [Frac #;Frac #la;FracP] [Text #;Text #la;TextP]) (^ [cursor (#;Tuple (list))]) @@ -225,14 +225,14 @@ [[inputT inputA] (&common;with-unknown-type (analyse input)) outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) - outputT (mapM @ - (function [[patternT bodyT]] - (analyse-pattern #;None inputT patternT (analyse bodyT))) - branchesT) - _ (case (foldM R;Monad<Result> - &&coverage;merge - (|> outputH product;left &&coverage;determine) - (L/map (|>. product;left &&coverage;determine) outputT)) + outputT (monad;map @ + (function [[patternT bodyT]] + (analyse-pattern #;None inputT patternT (analyse bodyT))) + branchesT) + _ (case (monad;fold R;Monad<Result> + &&coverage;merge + (|> outputH product;left &&coverage;determine) + (L/map (|>. product;left &&coverage;determine) outputT)) (#R;Success coverage) (if (&&coverage;total? coverage) (wrap []) diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux index 88e40ac0f..cb7341d7a 100644 --- a/new-luxc/source/luxc/analyser/case/coverage.lux +++ b/new-luxc/source/luxc/analyser/case/coverage.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] eq) (data [bool "B/" Eq<Bool>] [number] @@ -54,7 +54,7 @@ ## Primitive patterns always have partial coverage because there ## are too many possibilities as far as values go. (^or (#la;NatP _) (#la;IntP _) (#la;DegP _) - (#la;RealP _) (#la;TextP _)) + (#la;FracP _) (#la;TextP _)) #Partial ## Bools are the exception, since there is only "true" and @@ -171,17 +171,17 @@ ## else (do R;Monad<Result> - [casesM (foldM @ - (function [[tagA coverageA] casesSF'] - (case (D;get tagA casesSF') - (#;Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (D;put tagA coverageM casesSF'))) - - #;None - (wrap (D;put tagA coverageA casesSF')))) - casesSF (D;entries casesA))] + [casesM (monad;fold @ + (function [[tagA coverageA] casesSF'] + (case (D;get tagA casesSF') + (#;Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (D;put tagA coverageM casesSF'))) + + #;None + (wrap (D;put tagA coverageA casesSF')))) + casesSF (D;entries casesA))] (wrap (if (let [case-coverages (D;values casesM)] (and (n.= allSF (list;size case-coverages)) (list;every? total? case-coverages))) diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux index 9102acda5..69e4f2b07 100644 --- a/new-luxc/source/luxc/analyser/primitive.lux +++ b/new-luxc/source/luxc/analyser/primitive.lux @@ -20,7 +20,7 @@ [analyse-nat Nat #la;Nat] [analyse-int Int #la;Int] [analyse-deg Deg #la;Deg] - [analyse-real Real #la;Real] + [analyse-frac Frac #la;Frac] [analyse-text Text #la;Text] ) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux index d8778844f..06ea7c324 100644 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -1,10 +1,10 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (data [text] text/format (coll ["D" dict]) - maybe)) + [maybe])) (luxc ["&" base] (lang ["la" analysis #+ Analysis])) (. ["&&;" common])) @@ -12,6 +12,6 @@ (def: #export (analyse-procedure analyse proc-name proc-args) (-> &;Analyser Text (List Code) (Lux Analysis)) (default (&;fail (format "Unknown procedure: " (%t proc-name))) - (do Monad<Maybe> + (do maybe;Monad<Maybe> [proc (D;get proc-name &&common;procedures)] (wrap (proc analyse proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index 1976d266d..0ba35a82e 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (concurrency ["A" atom]) (data [text] text/format @@ -39,11 +39,11 @@ (let [num-actual (list;size args)] (if (n.= num-expected num-actual) (do Monad<Lux> - [argsA (mapM @ - (function [[argT argC]] - (&;with-expected-type argT - (analyse argC))) - (list;zip2 input-types args)) + [argsA (monad;map @ + (function [[argT argC]] + (&;with-expected-type argT + (analyse argC))) + (list;zip2 input-types args)) expected macro;expected-type _ (&;within-type-env (TC;check expected output-type))] @@ -156,7 +156,7 @@ (install "int min" (special-value Int)) (install "int max" (special-value Int)) (install "int to-nat" (converter Int Nat)) - (install "int to-real" (converter Int Real)))) + (install "int to-frac" (converter Int Frac)))) (def: deg-procs Bundle @@ -172,28 +172,28 @@ (install "deg reciprocal" (binary-operation Deg Nat Deg)) (install "deg min" (special-value Deg)) (install "deg max" (special-value Deg)) - (install "deg to-real" (converter Deg Real)))) + (install "deg to-frac" (converter Deg Frac)))) -(def: real-procs +(def: frac-procs Bundle (|> (D;new text;Hash<Text>) - (install "real +" (binary-operation Real Real Real)) - (install "real -" (binary-operation Real Real Real)) - (install "real *" (binary-operation Real Real Real)) - (install "real /" (binary-operation Real Real Real)) - (install "real %" (binary-operation Real Real Real)) - (install "real =" (binary-operation Real Real Bool)) - (install "real <" (binary-operation Real Real Bool)) - (install "real smallest" (special-value Real)) - (install "real min" (special-value Real)) - (install "real max" (special-value Real)) - (install "real not-a-number" (special-value Real)) - (install "real positive-infinity" (special-value Real)) - (install "real negative-infinity" (special-value Real)) - (install "real to-deg" (converter Real Deg)) - (install "real to-int" (converter Real Int)) - (install "real to-text" (converter Real Text)) - (install "real from-text" (converter Text (type (Maybe Real)))))) + (install "frac +" (binary-operation Frac Frac Frac)) + (install "frac -" (binary-operation Frac Frac Frac)) + (install "frac *" (binary-operation Frac Frac Frac)) + (install "frac /" (binary-operation Frac Frac Frac)) + (install "frac %" (binary-operation Frac Frac Frac)) + (install "frac =" (binary-operation Frac Frac Bool)) + (install "frac <" (binary-operation Frac Frac Bool)) + (install "frac smallest" (special-value Frac)) + (install "frac min" (special-value Frac)) + (install "frac max" (special-value Frac)) + (install "frac not-a-number" (special-value Frac)) + (install "frac positive-infinity" (special-value Frac)) + (install "frac negative-infinity" (special-value Frac)) + (install "frac to-deg" (converter Frac Deg)) + (install "frac to-int" (converter Frac Int)) + (install "frac encode" (converter Frac Text)) + (install "frac decode" (converter Text (type (Maybe Frac)))))) (def: text-procs Bundle @@ -246,24 +246,24 @@ (def: math-procs Bundle (|> (D;new text;Hash<Text>) - (install "math cos" (unary-operation Real Real)) - (install "math sin" (unary-operation Real Real)) - (install "math tan" (unary-operation Real Real)) - (install "math acos" (unary-operation Real Real)) - (install "math asin" (unary-operation Real Real)) - (install "math atan" (unary-operation Real Real)) - (install "math cosh" (unary-operation Real Real)) - (install "math sinh" (unary-operation Real Real)) - (install "math tanh" (unary-operation Real Real)) - (install "math exp" (unary-operation Real Real)) - (install "math log" (unary-operation Real Real)) - (install "math root2" (unary-operation Real Real)) - (install "math root3" (unary-operation Real Real)) - (install "math ceil" (unary-operation Real Real)) - (install "math floor" (unary-operation Real Real)) - (install "math round" (unary-operation Real Real)) - (install "math atan2" (binary-operation Real Real Real)) - (install "math pow" (binary-operation Real Real Real)) + (install "math cos" (unary-operation Frac Frac)) + (install "math sin" (unary-operation Frac Frac)) + (install "math tan" (unary-operation Frac Frac)) + (install "math acos" (unary-operation Frac Frac)) + (install "math asin" (unary-operation Frac Frac)) + (install "math atan" (unary-operation Frac Frac)) + (install "math cosh" (unary-operation Frac Frac)) + (install "math sinh" (unary-operation Frac Frac)) + (install "math tanh" (unary-operation Frac Frac)) + (install "math exp" (unary-operation Frac Frac)) + (install "math log" (unary-operation Frac Frac)) + (install "math root2" (unary-operation Frac Frac)) + (install "math root3" (unary-operation Frac Frac)) + (install "math ceil" (unary-operation Frac Frac)) + (install "math floor" (unary-operation Frac Frac)) + (install "math round" (unary-operation Frac Frac)) + (install "math atan2" (binary-operation Frac Frac Frac)) + (install "math pow" (binary-operation Frac Frac Frac)) )) (def: (analyse-atom-new proc) @@ -326,7 +326,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/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 267dfec84..ad7ad2a7a 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad + (lux (control [monad #+ do] pipe) [io #- run] [function] @@ -154,8 +154,8 @@ (analyse-product analyse membersC))) ## Must do inference... (do @ - [membersTA (mapM @ (|>. analyse &common;with-unknown-type) - membersC) + [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) + membersC) _ (&;within-type-env (TC;check expected (type;tuple (L/map product;left membersTA))))] @@ -198,17 +198,17 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Lux (List [Ident Code]))) - (mapM Monad<Lux> - (function [[key val]] - (case key - [_ (#;Tag key)] - (do Monad<Lux> - [key (macro;normalize key)] - (wrap [key val])) + (monad;map Monad<Lux> + (function [[key val]] + (case key + [_ (#;Tag key)] + (do Monad<Lux> + [key (macro;normalize key)] + (wrap [key val])) - _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) - record)) + _ + (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + record)) ## Lux already possesses the means to analyse tuples, so ## re-implementing the same functionality for records makes no sense. @@ -234,22 +234,22 @@ "For type: " (%type recordT)))) #let [tuple-range (list;n.range +0 (n.dec size-ts)) tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] - idx->val (foldM @ - (function [[key val] idx->val] - (do @ - [key (macro;normalize key)] - (case (D;get key tag->idx) - #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) + idx->val (monad;fold @ + (function [[key val] idx->val] + (do @ + [key (macro;normalize key)] + (case (D;get key tag->idx) + #;None + (&;fail (format "Tag " (%code (code;tag key)) + " does not belong to tag-set for type " (%type recordT))) - (#;Some idx) - (if (D;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) - (wrap (D;put idx val idx->val)))))) - (: (D;Dict Nat Code) - (D;new number;Hash<Nat>)) - record) + (#;Some idx) + (if (D;contains? idx idx->val) + (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (wrap (D;put idx val idx->val)))))) + (: (D;Dict Nat Code) + (D;new number;Hash<Nat>)) + record) #let [ordered-tuple (L/map (function [idx] (assume (D;get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) 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)))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index d5b4e89b0..00957f3d4 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (concurrency ["A" atom]) (data ["R" result] [text] @@ -8,7 +8,7 @@ (coll ["d" dict] [array #+ Array])) [macro #+ Monad<Lux>] - host + [host #+ jvm-import do-to object] [io]) (luxc ["&" base] (generator ["&&;" common]) @@ -34,12 +34,12 @@ (def: ClassLoader::defineClass Method (case (Class.getDeclaredMethod ["defineClass" - (|> (array (Class Object) +4) - (array-store +0 (:! (Class Object) (class-for String))) - (array-store +1 (Object.getClass [] (array byte +0))) - (array-store +2 (:! (Class Object) Integer.TYPE)) - (array-store +3 (:! (Class Object) Integer.TYPE)))] - (class-for java.lang.ClassLoader)) + (|> (host;array (Class Object) +4) + (host;array-write +0 (:! (Class Object) (host;class-for String))) + (host;array-write +1 (Object.getClass [] (host;array byte +0))) + (host;array-write +2 (:! (Class Object) Integer.TYPE)) + (host;array-write +3 (:! (Class Object) Integer.TYPE)))] + (host;class-for java.lang.ClassLoader)) (#R;Success method) (do-to method (AccessibleObject.setAccessible [true])) @@ -52,8 +52,8 @@ (Method.invoke [loader (array;from-list (list (:! Object class-name) (:! Object byte-code) - (:! Object (l2i 0)) - (:! Object (l2i (nat-to-int (array-length byte-code))))))] + (:! Object (host;l2i 0)) + (:! Object (host;l2i (nat-to-int (host;array-length byte-code))))))] ClassLoader::defineClass)) (def: (fetch-byte-code class-name store) diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux index 9b7c000f3..7a4ae37ac 100644 --- a/new-luxc/source/luxc/lang/analysis.lux +++ b/new-luxc/source/luxc/lang/analysis.lux @@ -8,7 +8,7 @@ (#NatP Nat) (#IntP Int) (#DegP Deg) - (#RealP Real) + (#FracP Frac) (#TextP Text) (#TupleP (List Pattern)) (#VariantP Nat Nat Pattern) @@ -20,7 +20,7 @@ (#Nat Nat) (#Int Int) (#Deg Deg) - (#Real Real) + (#Frac Frac) (#Text Text) (#Sum (Either Analysis Analysis)) (#Product Analysis Analysis) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index ad31d0138..e8f186944 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -11,7 +11,7 @@ (#NatP Nat) (#IntP Int) (#DegP Deg) - (#RealP Real) + (#FracP Frac) (#TextP Text) (#VariantP (Either Nat Nat) (Path' s)) (#TupleP (Either Nat Nat) (Path' s)) @@ -26,7 +26,7 @@ (#Nat Nat) (#Int Int) (#Deg Deg) - (#Real Real) + (#Frac Frac) (#Text Text) (#Variant Nat Bool Synthesis) (#Tuple (List Synthesis)) diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux index b53ceefed..68c43c0c1 100644 --- a/new-luxc/source/luxc/module.lux +++ b/new-luxc/source/luxc/module.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do]) (data [text "T/" Eq<Text>] text/format ["R" result] @@ -118,15 +118,15 @@ (-> Text (List Text) (Lux Unit)) (do Monad<Lux> [bindings (tags-by-module module-name) - _ (mapM @ - (function [tag] - (case (&;pl-get tag bindings) - #;None - (wrap []) - - (#;Some _) - (&;fail (format "Cannot re-declare tag: " tag)))) - tags)] + _ (monad;map @ + (function [tag] + (case (&;pl-get tag bindings) + #;None + (wrap []) + + (#;Some _) + (&;fail (format "Cannot re-declare tag: " tag)))) + tags)] (wrap []))) (def: #export (declare-tags tags exported? type) diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux index ed5419974..299616e6b 100644 --- a/new-luxc/source/luxc/module/descriptor/annotation.lux +++ b/new-luxc/source/luxc/module/descriptor/annotation.lux @@ -21,7 +21,7 @@ [nat-signal "N"] [int-signal "I"] [deg-signal "D"] - [real-signal "R"] + [frac-signal "R"] [text-signal "T"] [list-signal "%"] [dict-signal "#"] @@ -51,7 +51,7 @@ [#;NatA nat-signal %n] [#;IntA int-signal %i] [#;DegA deg-signal %d] - [#;RealA real-signal %r] + [#;FracA frac-signal %r] [#;TextA text-signal %t] [#;IdentA ident-signal %ident] [#;ListA list-signal (&;encode-list encode-ann-value)] diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux index 9778eb465..d061fdda5 100644 --- a/new-luxc/source/luxc/parser.lux +++ b/new-luxc/source/luxc/parser.lux @@ -232,7 +232,7 @@ rich-digits^) number;Codec<Text,Int>] - [parse-real #;Real + [parse-frac #;Frac ($_ l;seq (p;default "" (l;one-of "-")) rich-digits^ @@ -243,7 +243,7 @@ (l;one-of "eE") (p;default "" (l;one-of "+-")) (l;many l;decimal)))) - number;Codec<Text,Real>] + number;Codec<Text,Frac>] [parse-deg #;Deg (l;seq (l;one-of ".") @@ -512,7 +512,7 @@ (parse-record where parse-ast) (parse-bool where) (parse-nat where) - (parse-real where) + (parse-frac where) (parse-int where) (parse-deg where) (parse-symbol where) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index bd6220337..9cfcc020e 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -38,7 +38,7 @@ [#la;Nat #ls;Nat] [#la;Int #ls;Int] [#la;Deg #ls;Deg] - [#la;Real #ls;Real] + [#la;Frac #ls;Frac] [#la;Text #ls;Text] [#la;Definition #ls;Definition]) diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux index ee2ef84b0..8221b4f8d 100644 --- a/new-luxc/source/luxc/synthesizer/case.lux +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -20,7 +20,7 @@ [#la;NatP #ls;NatP] [#la;IntP #ls;IntP] [#la;DegP #ls;DegP] - [#la;RealP #ls;RealP] + [#la;FracP #ls;FracP] [#la;TextP #ls;TextP]) (#la;TupleP membersP) @@ -66,7 +66,7 @@ [#ls;NatP n.=] [#ls;IntP i.=] [#ls;DegP d.=] - [#ls;RealP r.=] + [#ls;FracP f.=] [#ls;TextP T/=]) (^template [<tag> <side>] |