From b4d0eba7485caf0c6cf58de1193a9114fa273d8b Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 30 May 2020 15:19:28 -0400
Subject: Split new-luxc into lux-jvm and lux-r.
---
new-luxc/source/luxc/lang/directive/jvm.lux | 538 ----------------------------
1 file changed, 538 deletions(-)
delete mode 100644 new-luxc/source/luxc/lang/directive/jvm.lux
(limited to 'new-luxc/source/luxc/lang/directive')
diff --git a/new-luxc/source/luxc/lang/directive/jvm.lux b/new-luxc/source/luxc/lang/directive/jvm.lux
deleted file mode 100644
index 27b1c8688..000000000
--- a/new-luxc/source/luxc/lang/directive/jvm.lux
+++ /dev/null
@@ -1,538 +0,0 @@
-(.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))))
--
cgit v1.2.3