- Heavy refactoring.

1 files changed, 383 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
new file mode 100644
index 000000000..37ab75020
--- /dev/null
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -0,0 +1,383 @@
+(;module:
+  [lux #- char]
+  (lux (control monad
+                ["p" parser])
+       (data [maybe]
+             ["e" error]
+             text/format
+             (coll [list "L/" Functor<List>]))
+       [host #+ do-to]
+       [meta]
+       (meta [code]
+             ["s" syntax #+ syntax:]))
+  ["$" ..]
+  (.. ["$t" type]))
+
+## [Host]
+(host;import #long java.lang.Object)
+(host;import #long java.lang.String)
+
+(syntax: (declare [codes (p;many s;local-symbol)])
+  (|> codes
+      (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
+      wrap))
+
+(`` (host;import org.objectweb.asm.Opcodes
+      (#static NOP int)
+
+      ## Conversion
+      (~~ (declare D2F D2I D2L
+                   F2D F2I F2L
+                   I2B I2C I2D I2F I2L I2S
+                   L2D L2F L2I))
+
+      ## Primitive
+      (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
+                   T_BYTE T_SHORT T_INT T_LONG))
+
+      ## Class
+      (~~ (declare CHECKCAST NEW INSTANCEOF))
+      
+      ## Stack
+      (~~ (declare DUP DUP_X1 DUP_X2
+                   DUP2 DUP2_X1 DUP2_X2
+                   POP POP2
+                   SWAP))
+      
+      ## Jump
+      (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
+                   IFEQ IFNE IFLT IFLE IFGT IFGE
+                   GOTO))
+
+      (#static ACONST_NULL int)
+      
+      ## Var
+      (~~ (declare ILOAD LLOAD DLOAD ALOAD
+                   ISTORE LSTORE ASTORE))
+      
+      ## Arithmetic
+      (~~ (declare IADD ISUB IMUL IDIV IREM
+                   LADD LSUB LMUL LDIV LREM LCMP
+                   FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+                   DADD DSUB DMUL DDIV DREM DCMPG DCMPL))
+      
+      ## Bit-wise
+      (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR
+                   LAND LOR LXOR LSHL LSHR LUSHR))
+
+      ## Array
+      (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY
+                   AALOAD AASTORE
+                   BALOAD BASTORE
+                   SALOAD SASTORE
+                   IALOAD IASTORE
+                   LALOAD LASTORE
+                   FALOAD FASTORE
+                   DALOAD DASTORE
+                   CALOAD CASTORE))
+      
+      ## Member
+      (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+                   INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
+
+      (#static ATHROW int)
+
+      ## Concurrency
+      (~~ (declare MONITORENTER MONITOREXIT))
+      
+      ## Return
+      (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
+      ))
+
+(host;import org.objectweb.asm.FieldVisitor
+  (visitEnd [] void))
+
+(host;import org.objectweb.asm.Label
+  (new []))
+
+(host;import org.objectweb.asm.MethodVisitor
+  (visitCode [] void)
+  (visitMaxs [int int] void)
+  (visitEnd [] void)
+  (visitInsn [int] void)
+  (visitLdcInsn [Object] void)
+  (visitFieldInsn [int String String String] void)
+  (visitTypeInsn [int String] void)
+  (visitVarInsn [int int] void)
+  (visitIntInsn [int int] void)
+  (visitMethodInsn [int String String String boolean] void)
+  (visitLabel [Label] void)
+  (visitJumpInsn [int Label] void)
+  (visitTryCatchBlock [Label Label Label String] void)
+  (visitTableSwitchInsn [int int Label (Array  Label)] void)
+  )
+
+## [Insts]
+(def: #export make-label
+  (Meta Label)
+  (function [compiler]
+    (#e;Success [compiler (Label.new [])])))
+
+(def: #export (with-label action)
+  (-> (-> Label $;Inst) $;Inst)
+  (action (Label.new [])))
+
+(do-template [<name> <type> <prepare>]
+  [(def: #export (<name> value)
+     (-> <type> $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitLdcInsn [(<prepare> value)]))))]
+
+  [boolean Bool id]
+  [int     Int  host;l2i]
+  [long    Int  id]
+  [double  Frac id]
+  [char    Nat  (|>. nat-to-int host;l2i host;i2c)]
+  [string  Text id]
+  )
+
+(syntax: (prefix [base s;local-symbol])
+  (wrap (list (code;local-symbol (format "Opcodes." base)))))
+
+(def: #export NULL
+  $;Inst
+  (function [visitor]
+    (do-to visitor
+      (MethodVisitor.visitInsn [(prefix ACONST_NULL)]))))
+
+(do-template [<name>]
+  [(def: #export <name>
+     $;Inst
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitInsn [(prefix <name>)]))))]
+
+  [NOP]
+  
+  ## Stack
+  [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
+  [POP] [POP2]
+  [SWAP]
+
+  ## Conversions
+  [D2F] [D2I] [D2L]
+  [F2D] [F2I] [F2L]
+  [I2B] [I2C] [I2D] [I2F] [I2L] [I2S]
+  [L2D] [L2F] [L2I]
+
+  ## Integer arithmetic
+  [IADD] [ISUB] [IMUL] [IDIV] [IREM]
+
+  ## Integer bitwise
+  [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
+  
+  ## Long arithmetic
+  [LADD] [LSUB] [LMUL] [LDIV] [LREM]
+  [LCMP]
+
+  ## Long bitwise
+  [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+
+  ## Float arithmetic
+  [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL]
+
+  ## Double arithmetic
+  [DADD] [DSUB] [DMUL] [DDIV] [DREM]
+  [DCMPG] [DCMPL]
+
+  ## Array
+  [ARRAYLENGTH]
+  [AALOAD] [AASTORE]
+  [BALOAD] [BASTORE]
+  [SALOAD] [SASTORE]
+  [IALOAD] [IASTORE]
+  [LALOAD] [LASTORE]
+  [FALOAD] [FASTORE]
+  [DALOAD] [DASTORE]
+  [CALOAD] [CASTORE]
+
+  ## Exceptions
+  [ATHROW]
+
+  ## Concurrency
+  [MONITORENTER] [MONITOREXIT]
+
+  ## Return
+  [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
+  )
+
+(do-template [<name>]
+  [(def: #export (<name> register)
+     (-> Nat $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))]
+
+  [ILOAD] [LLOAD] [DLOAD] [ALOAD]
+  [ISTORE] [LSTORE] [ASTORE]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class field type)
+     (-> Text Text $;Type $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]
+
+  [GETSTATIC Opcodes.GETSTATIC]
+  [PUTSTATIC Opcodes.PUTSTATIC]
+  
+  [PUTFIELD  Opcodes.PUTFIELD]
+  [GETFIELD  Opcodes.GETFIELD]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class)
+     (-> Text $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
+
+  [CHECKCAST  Opcodes.CHECKCAST]
+  [NEW        Opcodes.NEW]
+  [INSTANCEOF Opcodes.INSTANCEOF]
+  [ANEWARRAY  Opcodes.ANEWARRAY]
+  )
+
+(def: #export (NEWARRAY type)
+  (-> $;Primitive $;Inst)
+  (function [visitor]
+    (do-to visitor
+      (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
+                                                      #$;Boolean Opcodes.T_BOOLEAN
+                                                      #$;Byte    Opcodes.T_BYTE
+                                                      #$;Short   Opcodes.T_SHORT
+                                                      #$;Int     Opcodes.T_INT
+                                                      #$;Long    Opcodes.T_LONG
+                                                      #$;Float   Opcodes.T_FLOAT
+                                                      #$;Double  Opcodes.T_DOUBLE
+                                                      #$;Char    Opcodes.T_CHAR)]))))
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class method-name method-signature interface?)
+     (-> Text Text $;Method Bool $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]
+
+  [INVOKESTATIC    Opcodes.INVOKESTATIC]
+  [INVOKEVIRTUAL   Opcodes.INVOKEVIRTUAL]
+  [INVOKESPECIAL   Opcodes.INVOKESPECIAL]
+  [INVOKEINTERFACE Opcodes.INVOKEINTERFACE]
+  )
+
+(do-template [<name>]
+  [(def: #export (<name> @where)
+     (-> $;Label $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
+
+  [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL]
+  [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
+  [GOTO]
+  )
+
+(def: #export (TABLESWITCH min max default labels)
+  (-> Int Int $;Label (List $;Label) $;Inst)
+  (function [visitor]
+    (let [num-labels (list;size labels)
+          labels-array (host;array Label num-labels)
+          _ (loop [idx +0]
+              (if (n.< num-labels idx)
+                (exec (host;array-write idx
+                                        (maybe;assume (list;nth idx labels))
+                                        labels-array)
+                  (recur (n.inc idx)))
+                []))]
+      (do-to visitor
+        (MethodVisitor.visitTableSwitchInsn [min max default labels-array])))))
+
+(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]
+    (do-to visitor
+      (MethodVisitor.visitLabel [@label]))))
+
+(def: #export (array type)
+  (-> $;Type $;Inst)
+  (case type
+    (#$;Primitive prim)
+    (NEWARRAY prim)
+
+    (#$;Generic generic)
+    (let [elem-class (case generic
+                       (#$;Class class params)
+                       ($t;binary-name class)
+
+                       _
+                       ($t;binary-name "java.lang.Object"))]
+      (ANEWARRAY elem-class))
+
+    _
+    (ANEWARRAY ($t;descriptor type))))
+
+(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)
+  (case insts
+    #;Nil
+    id
+
+    (#;Cons singleton #;Nil)
+    singleton
+
+    (#;Cons head tail)
+    (. (fuse tail) head)))