Split new-luxc into lux-jvm and lux-r.

1 files changed, 538 insertions, 0 deletions

diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux
new file mode 100644
index 000000000..27b1c8688
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/directive/jvm.lux
@@ -0,0 +1,538 @@
+(.module:
+  [lux #*
+   [host (#+ import:)]
+   [type (#+ :share)]
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try (#+ Try)]]
+   [target
+    ["/" jvm]]
+   [data
+    [identity (#+ Identity)]
+    ["." product]
+    [number
+     ["." nat]]
+    [text
+     ["%" format (#+ format)]]
+    [collection
+     ["." list ("#@." fold)]
+     ["." dictionary (#+ Dictionary)]
+     ["." row (#+ Row) ("#@." functor fold)]]]
+   [tool
+    [compiler
+     ["." phase]
+     [language
+      [lux
+       [synthesis (#+ Synthesis)]
+       ["." generation]
+       ["." directive]
+       [phase
+        ["." extension
+         ["." bundle]
+         [directive
+          ["./" lux]]]]]]]]]
+  [///
+   [host
+    ["." jvm (#+ Inst)
+     ["_" inst]]]])
+
+(import: #long org/objectweb/asm/Label
+  (new []))
+
+(def: (literal literal)
+  (-> /.Literal Inst)
+  (case literal
+    (#/.Boolean value) (_.boolean value)
+    (#/.Int value) (_.int value)
+    (#/.Long value) (_.long value)
+    (#/.Double value) (_.double value)
+    (#/.Char value) (_.char value)
+    (#/.String value) (_.string value)))
+
+(def: (constant instruction)
+  (-> /.Constant Inst)
+  (case instruction
+    (#/.BIPUSH constant) (_.BIPUSH constant)
+    
+    (#/.SIPUSH constant) (_.SIPUSH constant)
+
+    #/.ICONST_M1 _.ICONST_M1
+    #/.ICONST_0 _.ICONST_0
+    #/.ICONST_1 _.ICONST_1
+    #/.ICONST_2 _.ICONST_2
+    #/.ICONST_3 _.ICONST_3
+    #/.ICONST_4 _.ICONST_4
+    #/.ICONST_5 _.ICONST_5
+
+    #/.LCONST_0 _.LCONST_0
+    #/.LCONST_1 _.LCONST_1
+    
+    #/.FCONST_0 _.FCONST_0
+    #/.FCONST_1 _.FCONST_1
+    #/.FCONST_2 _.FCONST_2
+    
+    #/.DCONST_0 _.DCONST_0
+    #/.DCONST_1 _.DCONST_1
+    
+    #/.ACONST_NULL _.NULL
+
+    (#/.LDC literal)
+    (..literal literal)
+    ))
+
+(def: (int-arithmetic instruction)
+  (-> /.Int-Arithmetic Inst)
+  (case instruction
+    #/.IADD _.IADD
+    #/.ISUB _.ISUB
+    #/.IMUL _.IMUL
+    #/.IDIV _.IDIV
+    #/.IREM _.IREM
+    #/.INEG _.INEG))
+
+(def: (long-arithmetic instruction)
+  (-> /.Long-Arithmetic Inst)
+  (case instruction
+    #/.LADD _.LADD
+    #/.LSUB _.LSUB
+    #/.LMUL _.LMUL
+    #/.LDIV _.LDIV
+    #/.LREM _.LREM
+    #/.LNEG _.LNEG))
+
+(def: (float-arithmetic instruction)
+  (-> /.Float-Arithmetic Inst)
+  (case instruction
+    #/.FADD _.FADD
+    #/.FSUB _.FSUB
+    #/.FMUL _.FMUL
+    #/.FDIV _.FDIV
+    #/.FREM _.FREM
+    #/.FNEG _.FNEG))
+
+(def: (double-arithmetic instruction)
+  (-> /.Double-Arithmetic Inst)
+  (case instruction
+    #/.DADD _.DADD
+    #/.DSUB _.DSUB
+    #/.DMUL _.DMUL
+    #/.DDIV _.DDIV
+    #/.DREM _.DREM
+    #/.DNEG _.DNEG))
+
+(def: (arithmetic instruction)
+  (-> /.Arithmetic Inst)
+  (case instruction
+    (#/.Int-Arithmetic int-arithmetic)
+    (..int-arithmetic int-arithmetic)
+    
+    (#/.Long-Arithmetic long-arithmetic)
+    (..long-arithmetic long-arithmetic)
+    
+    (#/.Float-Arithmetic float-arithmetic)
+    (..float-arithmetic float-arithmetic)
+    
+    (#/.Double-Arithmetic double-arithmetic)
+    (..double-arithmetic double-arithmetic)))
+
+(def: (int-bitwise instruction)
+  (-> /.Int-Bitwise Inst)
+  (case instruction
+    #/.IOR _.IOR
+    #/.IXOR _.IXOR
+    #/.IAND _.IAND
+    #/.ISHL _.ISHL
+    #/.ISHR _.ISHR
+    #/.IUSHR _.IUSHR))
+
+(def: (long-bitwise instruction)
+  (-> /.Long-Bitwise Inst)
+  (case instruction
+    #/.LOR _.LOR
+    #/.LXOR _.LXOR
+    #/.LAND _.LAND
+    #/.LSHL _.LSHL
+    #/.LSHR _.LSHR
+    #/.LUSHR _.LUSHR))
+
+(def: (bitwise instruction)
+  (-> /.Bitwise Inst)
+  (case instruction
+    (#/.Int-Bitwise int-bitwise)
+    (..int-bitwise int-bitwise)
+    
+    (#/.Long-Bitwise long-bitwise)
+    (..long-bitwise long-bitwise)))
+
+(def: (conversion instruction)
+  (-> /.Conversion Inst)
+  (case instruction
+    #/.I2B _.I2B
+    #/.I2S _.I2S
+    #/.I2L _.I2L
+    #/.I2F _.I2F
+    #/.I2D _.I2D
+    #/.I2C _.I2C
+
+    #/.L2I _.L2I
+    #/.L2F _.L2F
+    #/.L2D _.L2D
+
+    #/.F2I _.F2I
+    #/.F2L _.F2L
+    #/.F2D _.F2D
+    
+    #/.D2I _.D2I
+    #/.D2L _.D2L
+    #/.D2F _.D2F))
+
+(def: (array instruction)
+  (-> /.Array Inst)
+  (case instruction
+    #/.ARRAYLENGTH _.ARRAYLENGTH
+
+    (#/.NEWARRAY type) (_.NEWARRAY type)
+    (#/.ANEWARRAY type) (_.ANEWARRAY type)
+
+    #/.BALOAD _.BALOAD
+    #/.BASTORE _.BASTORE
+
+    #/.SALOAD _.SALOAD
+    #/.SASTORE _.SASTORE
+
+    #/.IALOAD _.IALOAD
+    #/.IASTORE _.IASTORE
+
+    #/.LALOAD _.LALOAD
+    #/.LASTORE _.LASTORE
+
+    #/.FALOAD _.FALOAD
+    #/.FASTORE _.FASTORE
+
+    #/.DALOAD _.DALOAD
+    #/.DASTORE _.DASTORE
+    
+    #/.CALOAD _.CALOAD
+    #/.CASTORE _.CASTORE
+
+    #/.AALOAD _.AALOAD
+    #/.AASTORE _.AASTORE))
+
+(def: (object instruction)
+  (-> /.Object Inst)
+  (case instruction
+    (^template [<tag> <inst>]
+      (<tag> class field-name field-type)
+      (<inst> class field-name field-type))
+    ([#/.GETSTATIC _.GETSTATIC]
+     [#/.PUTSTATIC _.PUTSTATIC]
+     [#/.GETFIELD _.GETFIELD]
+     [#/.PUTFIELD _.PUTFIELD])
+    
+    (#/.NEW type) (_.NEW type)
+    
+    (#/.INSTANCEOF type) (_.INSTANCEOF type)
+    (#/.CHECKCAST type) (_.CHECKCAST type)
+
+    (^template [<tag> <inst>]
+      (<tag> class method-name method-type)
+      (<inst> class method-name method-type))
+    ([#/.INVOKEINTERFACE _.INVOKEINTERFACE]
+     [#/.INVOKESPECIAL _.INVOKESPECIAL]
+     [#/.INVOKESTATIC _.INVOKESTATIC]
+     [#/.INVOKEVIRTUAL _.INVOKEVIRTUAL])
+    ))
+
+(def: (local-int instruction)
+  (-> /.Local-Int Inst)
+  (case instruction
+    (#/.ILOAD register) (_.ILOAD register)
+    (#/.ISTORE register) (_.ISTORE register)))
+
+(def: (local-long instruction)
+  (-> /.Local-Long Inst)
+  (case instruction
+    (#/.LLOAD register) (_.LLOAD register)
+    (#/.LSTORE register) (_.LSTORE register)))
+
+(def: (local-float instruction)
+  (-> /.Local-Float Inst)
+  (case instruction
+    (#/.FLOAD register) (_.FLOAD register)
+    (#/.FSTORE register) (_.FSTORE register)))
+
+(def: (local-double instruction)
+  (-> /.Local-Double Inst)
+  (case instruction
+    (#/.DLOAD register) (_.DLOAD register)
+    (#/.DSTORE register) (_.DSTORE register)))
+
+(def: (local-object instruction)
+  (-> /.Local-Object Inst)
+  (case instruction
+    (#/.ALOAD register) (_.ALOAD register)
+    (#/.ASTORE register) (_.ASTORE register)))
+
+(def: (local instruction)
+  (-> /.Local Inst)
+  (case instruction
+    (#/.Local-Int instruction) (..local-int instruction)
+    (#/.IINC register) (_.IINC register)
+    (#/.Local-Long instruction) (..local-long instruction)
+    (#/.Local-Float instruction) (..local-float instruction)
+    (#/.Local-Double instruction) (..local-double instruction)
+    (#/.Local-Object instruction) (..local-object instruction)))
+
+(def: (stack instruction)
+  (-> /.Stack Inst)
+  (case instruction
+    #/.DUP _.DUP
+    #/.DUP_X1 _.DUP_X1
+    #/.DUP_X2 _.DUP_X2
+    #/.DUP2 _.DUP2
+    #/.DUP2_X1 _.DUP2_X1
+    #/.DUP2_X2 _.DUP2_X2
+    #/.SWAP _.SWAP
+    #/.POP _.POP
+    #/.POP2 _.POP2))
+
+(def: (comparison instruction)
+  (-> /.Comparison Inst)
+  (case instruction
+    #/.LCMP _.LCMP
+    
+    #/.FCMPG _.FCMPG
+    #/.FCMPL _.FCMPL
+
+    #/.DCMPG _.DCMPG
+    #/.DCMPL _.DCMPL))
+
+(def: (branching instruction)
+  (-> (/.Branching org/objectweb/asm/Label) Inst)
+  (case instruction
+    (#/.IF_ICMPEQ label) (_.IF_ICMPEQ label)
+    (#/.IF_ICMPGE label) (_.IF_ICMPGE label)
+    (#/.IF_ICMPGT label) (_.IF_ICMPGT label)
+    (#/.IF_ICMPLE label) (_.IF_ICMPLE label)
+    (#/.IF_ICMPLT label) (_.IF_ICMPLT label)
+    (#/.IF_ICMPNE label) (_.IF_ICMPNE label)
+    (#/.IFEQ label) (_.IFEQ label)
+    (#/.IFGE label) (_.IFGE label)
+    (#/.IFGT label) (_.IFGT label)
+    (#/.IFLE label) (_.IFLE label)
+    (#/.IFLT label) (_.IFLT label)
+    (#/.IFNE label) (_.IFNE label)
+
+    (#/.TABLESWITCH min max default labels)
+    (_.TABLESWITCH min max default labels)
+    
+    (#/.LOOKUPSWITCH default keys+labels)
+    (_.LOOKUPSWITCH default keys+labels)
+
+    (#/.IF_ACMPEQ label) (_.IF_ACMPEQ label)
+    (#/.IF_ACMPNE label) (_.IF_ACMPNE label)
+    (#/.IFNONNULL label) (_.IFNONNULL label)
+    (#/.IFNULL label) (_.IFNULL label)))
+
+(def: (exception instruction)
+  (-> (/.Exception org/objectweb/asm/Label) Inst)
+  (case instruction
+    (#/.Try start end handler exception) (_.try start end handler exception)
+    #/.ATHROW _.ATHROW))
+
+(def: (concurrency instruction)
+  (-> /.Concurrency Inst)
+  (case instruction
+    #/.MONITORENTER _.MONITORENTER
+    #/.MONITOREXIT _.MONITOREXIT))
+
+(def: (return instruction)
+  (-> /.Return Inst)
+  (case instruction
+    #/.RETURN _.RETURN
+    #/.IRETURN _.IRETURN
+    #/.LRETURN _.LRETURN
+    #/.FRETURN _.FRETURN
+    #/.DRETURN _.DRETURN
+    #/.ARETURN _.ARETURN))
+
+(def: (control instruction)
+  (-> (/.Control org/objectweb/asm/Label) Inst)
+  (case instruction
+    (#/.GOTO label) (_.GOTO label)
+    (#/.Branching instruction) (..branching instruction)
+    (#/.Exception instruction) (..exception instruction)
+    (#/.Concurrency instruction) (..concurrency instruction)
+    (#/.Return instruction) (..return instruction)))
+
+(def: (instruction instruction)
+  (-> (/.Instruction org/objectweb/asm/Label) Inst)
+  (case instruction
+    #/.NOP _.NOP
+    (#/.Constant instruction) (..constant instruction)
+    (#/.Arithmetic instruction) (..arithmetic instruction)
+    (#/.Bitwise instruction) (..bitwise instruction)
+    (#/.Conversion instruction) (..conversion instruction)
+    (#/.Array instruction) (..array instruction)
+    (#/.Object instruction) (..object instruction)
+    (#/.Local instruction) (..local instruction)
+    (#/.Stack instruction) (..stack instruction)
+    (#/.Comparison instruction) (..comparison instruction)
+    (#/.Control instruction) (..control instruction)))
+
+(type: Mapping
+  (Dictionary /.Label org/objectweb/asm/Label))
+
+(type: (Re-labeler context)
+  (-> [Mapping (context /.Label)]
+      [Mapping (context org/objectweb/asm/Label)]))
+
+(def: (relabel [mapping label])
+  (Re-labeler Identity)
+  (case (dictionary.get label mapping)
+    (#.Some label)
+    [mapping label]
+
+    #.None
+    (let [label' (org/objectweb/asm/Label::new)]
+      [(dictionary.put label label' mapping) label'])))
+
+(def: (relabel-branching [mapping instruction])
+  (Re-labeler /.Branching)
+  (case instruction
+    (^template [<tag>]
+      (<tag> label)
+      (let [[mapping label] (..relabel [mapping label])]
+        [mapping (<tag> label)]))
+    ([#/.IF_ICMPEQ] [#/.IF_ICMPGE] [#/.IF_ICMPGT] [#/.IF_ICMPLE] [#/.IF_ICMPLT] [#/.IF_ICMPNE]
+     [#/.IFEQ] [#/.IFNE] [#/.IFGE] [#/.IFGT] [#/.IFLE] [#/.IFLT]
+
+     [#/.IF_ACMPEQ] [#/.IF_ACMPNE] [#/.IFNONNULL] [#/.IFNULL])
+
+    (#/.TABLESWITCH min max default labels)
+    (let [[mapping default] (..relabel [mapping default])
+          [mapping labels] (list@fold (function (_ input [mapping output])
+                                        (let [[mapping input] (..relabel [mapping input])]
+                                          [mapping (list& input output)]))
+                                      [mapping (list)] labels)]
+      [mapping (#/.TABLESWITCH min max default (list.reverse labels))])
+    
+    (#/.LOOKUPSWITCH default keys+labels)
+    (let [[mapping default] (..relabel [mapping default])
+          [mapping keys+labels] (list@fold (function (_ [expected input] [mapping output])
+                                             (let [[mapping input] (..relabel [mapping input])]
+                                               [mapping (list& [expected input] output)]))
+                                           [mapping (list)] keys+labels)]
+      [mapping (#/.LOOKUPSWITCH default (list.reverse keys+labels))])
+    ))
+
+(def: (relabel-exception [mapping instruction])
+  (Re-labeler /.Exception)
+  (case instruction
+    (#/.Try start end handler exception)
+    (let [[mapping start] (..relabel [mapping start])
+          [mapping end] (..relabel [mapping end])
+          [mapping handler] (..relabel [mapping handler])]
+      [mapping (#/.Try start end handler exception)])
+    
+    #/.ATHROW
+    [mapping #/.ATHROW]
+    ))
+
+(def: (relabel-control [mapping instruction])
+  (Re-labeler /.Control)
+  (case instruction
+    (^template [<tag> <relabel>]
+      (<tag> instruction)
+      (let [[mapping instruction] (<relabel> [mapping instruction])]
+        [mapping (<tag> instruction)]))
+    ([#/.GOTO ..relabel]
+     [#/.Branching ..relabel-branching]
+     [#/.Exception ..relabel-exception])
+
+    (^template [<tag>]
+      (<tag> instruction)
+      [mapping (<tag> instruction)])
+    ([#/.Concurrency] [#/.Return])
+    ))
+
+(def: (relabel-instruction [mapping instruction])
+  (Re-labeler /.Instruction)
+  (case instruction
+    #/.NOP [mapping #/.NOP]
+
+    (^template [<tag>]
+      (<tag> instruction)
+      [mapping (<tag> instruction)])
+    ([#/.Constant]
+     [#/.Arithmetic]
+     [#/.Bitwise]
+     [#/.Conversion]
+     [#/.Array]
+     [#/.Object]
+     [#/.Local]
+     [#/.Stack]
+     [#/.Comparison])
+    
+    (#/.Control instruction)
+    (let [[mapping instruction] (..relabel-control [mapping instruction])]
+      [mapping (#/.Control instruction)])))
+
+(def: (relabel-bytecode [mapping bytecode])
+  (Re-labeler /.Bytecode)
+  (row@fold (function (_ input [mapping output])
+              (let [[mapping input] (..relabel-instruction [mapping input])]
+                [mapping (row.add input output)]))
+            [mapping (row.row)]
+            bytecode))
+
+(def: fresh
+  Mapping
+  (dictionary.new nat.hash))
+
+(def: bytecode
+  (-> (/.Bytecode /.Label) Inst)
+  (|>> [..fresh]
+       ..relabel-bytecode
+       product.right
+       (row@map ..instruction)
+       row.to-list
+       _.fuse))
+
+(type: Pseudo-Handler
+  (-> Text (List Synthesis) (Try (/.Bytecode /.Label))))
+
+(def: (true-handler pseudo)
+  (-> Pseudo-Handler jvm.Handler)
+  (function (_ extension-name phase archive inputs)
+    (|> (pseudo extension-name inputs)
+        (:: try.monad map ..bytecode)
+        phase.lift)))
+
+(def: (def::generation extender)
+  (-> jvm.Extender
+      (directive.Handler jvm.Anchor jvm.Inst jvm.Definition))
+  (function (handler extension-name phase archive inputsC+)
+    (case inputsC+
+      (^ (list nameC valueC))
+      (do phase.monad
+        [[_ _ name] (lux/.evaluate! archive Text nameC)
+         [_ _ pseudo-handlerV] (lux/.evaluate! archive ..Pseudo-Handler valueC)
+         _ (|> pseudo-handlerV
+               (:coerce ..Pseudo-Handler)
+               ..true-handler
+               (extension.install extender (:coerce Text name))
+               directive.lift-generation)
+         _ (directive.lift-generation
+            (generation.log! (format "Generation " (%.text (:coerce Text name)))))]
+        (wrap directive.no-requirements))
+
+      _
+      (phase.throw extension.invalid-syntax [extension-name %.code inputsC+]))))
+
+(def: #export (bundle extender)
+  (-> jvm.Extender
+      (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition))
+  (|> bundle.empty
+      (dictionary.put "lux def generation" (..def::generation extender))))