path: root/lux-jvm/source/luxc/lang/host/jvm/inst.lux

(.module:
  [library
   [lux (#- Type int char try)
    ["." ffi (#+ import: do_to)]
    [abstract
     [monad (#+ do)]]
    [control
     ["." function]
     ["." try]
     ["p" parser
      ["s" code]]]
    [data
     ["." product]
     ["." maybe]
     [collection
      ["." list ("#@." functor)]]]
    [macro
     [syntax (#+ syntax:)]
     ["." code]
     ["." template]]
    [math
     [number
      ["n" nat]
      ["i" int]]]
    [target
     [jvm
      [encoding
       ["." name (#+ External)]]
      ["." type (#+ Type) ("#@." equivalence)
       [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
       ["." box]
       ["." descriptor]
       ["." reflection]]]]
    [tool
     [compiler
      [phase (#+ Operation)]]]]]
  ["." // (#+ Inst)])

(def: class_name (|>> type.descriptor descriptor.class_name name.read))
(def: descriptor (|>> type.descriptor descriptor.descriptor))
(def: reflection (|>> type.reflection reflection.reflection))

## [Host]
(import: java/lang/Object)
(import: java/lang/String)

(syntax: (declare {codes (p.many s.local_identifier)})
  (|> codes
      (list@map (function (_ code) (` ((~' #static) (~ (code.local_identifier code)) (~' int)))))
      wrap))

(`` (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_ICMPNE IF_ICMPGE IF_ICMPLE
                    IF_ACMPEQ IF_ACMPNE IFNULL IFNONNULL
                    IFEQ IFNE IFLT IFLE IFGT IFGE
                    GOTO))

       (~~ (declare BIPUSH SIPUSH))
       (~~ (declare ICONST_M1 ICONST_0 ICONST_1 ICONST_2 ICONST_3 ICONST_4 ICONST_5
                    LCONST_0 LCONST_1
                    FCONST_0 FCONST_1 FCONST_2
                    DCONST_0 DCONST_1))
       (#static ACONST_NULL int)
       
       ## Var
       (~~ (declare IINC
                    ILOAD LLOAD FLOAD DLOAD ALOAD
                    ISTORE LSTORE FSTORE DSTORE ASTORE))
       
       ## Arithmetic
       (~~ (declare IADD ISUB IMUL IDIV IREM INEG
                    LADD LSUB LMUL LDIV LREM LNEG LCMP
                    FADD FSUB FMUL FDIV FREM FNEG FCMPG FCMPL
                    DADD DSUB DMUL DDIV DREM DNEG 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 FRETURN DRETURN ARETURN))]
      ))

(import: org/objectweb/asm/Label
  ["#::."
   (new [])])

(import: org/objectweb/asm/MethodVisitor
  ["#::."
   (visitCode [] void)
   (visitMaxs [int int] void)
   (visitEnd [] void)
   (visitInsn [int] void)
   (visitLdcInsn [java/lang/Object] void)
   (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void)
   (visitTypeInsn [int java/lang/String] void)
   (visitVarInsn [int int] void)
   (visitIntInsn [int int] void)
   (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void)
   (visitLabel [org/objectweb/asm/Label] void)
   (visitJumpInsn [int org/objectweb/asm/Label] void)
   (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void)
   (visitLookupSwitchInsn [org/objectweb/asm/Label [int] [org/objectweb/asm/Label]] void)
   (visitTableSwitchInsn [int int org/objectweb/asm/Label [org/objectweb/asm/Label]] void)
   ])

## [Insts]
(def: #export make_label
  (All [s] (Operation s org/objectweb/asm/Label))
  (function (_ state)
    (#try.Success [state (org/objectweb/asm/Label::new)])))

(def: #export (with_label action)
  (All [a] (-> (-> org/objectweb/asm/Label a) a))
  (action (org/objectweb/asm/Label::new)))

(template [<name> <type> <prepare>]
  [(def: #export (<name> value)
     (-> <type> Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))]

  [boolean Bit  function.identity]
  [int     Int  ffi.long_to_int]
  [long    Int  function.identity]
  [double  Frac function.identity]
  [char    Nat  (|>> .int ffi.long_to_int ffi.int_to_char)]
  [string  Text function.identity]
  )

(template: (!prefix short)
  (`` ((~~ (template.identifier ["org/objectweb/asm/Opcodes::" short])))))

(template [<constant>]
  [(def: #export <constant>
     Inst
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitInsn (!prefix <constant>)))))]

  [ICONST_M1] [ICONST_0] [ICONST_1] [ICONST_2] [ICONST_3] [ICONST_4] [ICONST_5]
  [LCONST_0] [LCONST_1]
  [FCONST_0] [FCONST_1] [FCONST_2]
  [DCONST_0] [DCONST_1]
  )

(def: #export NULL
  Inst
  (function (_ visitor)
    (do_to visitor
      (org/objectweb/asm/MethodVisitor::visitInsn (!prefix ACONST_NULL)))))

(template [<constant>]
  [(def: #export (<constant> constant)
     (-> Int Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitIntInsn (!prefix <constant>) constant))))]

  [BIPUSH]
  [SIPUSH]
  )

(template [<name>]
  [(def: #export <name>
     Inst
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/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] [INEG]

  ## Integer bitwise
  [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
  
  ## Long arithmetic
  [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LNEG]
  [LCMP]

  ## Long bitwise
  [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]

  ## Float arithmetic
  [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FNEG] [FCMPG] [FCMPL]

  ## Double arithmetic
  [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DNEG]
  [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] [FRETURN] [DRETURN] [ARETURN]
  )

(type: #export Register Nat)

(template [<name>]
  [(def: #export (<name> register)
     (-> Register Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitVarInsn (!prefix <name>) (.int register)))))]

  [IINC]
  [ILOAD] [LLOAD] [FLOAD] [DLOAD] [ALOAD]
  [ISTORE] [LSTORE] [FSTORE] [DSTORE] [ASTORE]
  )

(template [<name> <inst>]
  [(def: #export (<name> class field type)
     (-> (Type Class) Text (Type Value) Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (..class_name class) field (..descriptor type)))))]

  [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
  [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
  
  [PUTFIELD  org/objectweb/asm/Opcodes::PUTFIELD]
  [GETFIELD  org/objectweb/asm/Opcodes::GETFIELD]
  )

(template [<category> <instructions>+]
  [(`` (template [<name> <inst>]
         [(def: #export (<name> class)
            (-> (Type <category>) Inst)
            (function (_ visitor)
              (do_to visitor
                (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (..class_name class)))))]

         (~~ (template.splice <instructions>+))))]

  [Object
   [[CHECKCAST  org/objectweb/asm/Opcodes::CHECKCAST]
    [ANEWARRAY  org/objectweb/asm/Opcodes::ANEWARRAY]]]

  [Class
   [[NEW        org/objectweb/asm/Opcodes::NEW]
    [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]]]
  )

(def: #export (NEWARRAY type)
  (-> (Type Primitive) Inst)
  (function (_ visitor)
    (do_to visitor
      (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
                                                     (`` (cond (~~ (template [<descriptor> <opcode>]
                                                                     [(type@= <descriptor> type) (<opcode>)]
                                                                     
                                                                     [type.boolean org/objectweb/asm/Opcodes::T_BOOLEAN]
                                                                     [type.byte    org/objectweb/asm/Opcodes::T_BYTE]
                                                                     [type.short   org/objectweb/asm/Opcodes::T_SHORT]
                                                                     [type.int     org/objectweb/asm/Opcodes::T_INT]
                                                                     [type.long    org/objectweb/asm/Opcodes::T_LONG]
                                                                     [type.float   org/objectweb/asm/Opcodes::T_FLOAT]
                                                                     [type.double  org/objectweb/asm/Opcodes::T_DOUBLE]
                                                                     [type.char    org/objectweb/asm/Opcodes::T_CHAR]))
                                                               ## else
                                                               (undefined)))))))

(template [<name> <inst> <interface?>]
  [(def: #export (<name> class method_name method)
     (-> (Type Class) Text (Type Method) Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>)
                                                           (..class_name class)
                                                           method_name
                                                           (|> method type.descriptor descriptor.descriptor)
                                                           <interface?>))))]

  [INVOKESTATIC    org/objectweb/asm/Opcodes::INVOKESTATIC false]
  [INVOKEVIRTUAL   org/objectweb/asm/Opcodes::INVOKEVIRTUAL false]
  [INVOKESPECIAL   org/objectweb/asm/Opcodes::INVOKESPECIAL false]
  [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE true]
  )

(template [<name>]
  [(def: #export (<name> @where)
     (-> //.Label Inst)
     (function (_ visitor)
       (do_to visitor
         (org/objectweb/asm/MethodVisitor::visitJumpInsn (!prefix <name>) @where))))]

  [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT]
  [IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
  [IF_ACMPEQ] [IF_ACMPNE] [IFNULL] [IFNONNULL]
  [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
  [GOTO]
  )

(def: #export (LOOKUPSWITCH default keys+labels)
  (-> //.Label (List [Int //.Label]) Inst)
  (function (_ visitor)
    (let [keys+labels (list.sort (function (_ left right)
                                   (i.< (product.left left) (product.left right)))
                                 keys+labels)
          array_size (list.size keys+labels)
          keys_array (ffi.array int array_size)
          labels_array (ffi.array org/objectweb/asm/Label array_size)
          _ (loop [idx 0]
              (if (n.< array_size idx)
                (let [[key label] (maybe.assume (list.nth idx keys+labels))]
                  (exec
                    (ffi.array_write idx (ffi.long_to_int key) keys_array)
                    (ffi.array_write idx label labels_array)
                    (recur (inc idx))))
                []))]
      (do_to visitor
        (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys_array labels_array)))))

(def: #export (TABLESWITCH min max default labels)
  (-> Int Int //.Label (List //.Label) Inst)
  (function (_ visitor)
    (let [num_labels (list.size labels)
          labels_array (ffi.array org/objectweb/asm/Label num_labels)
          _ (loop [idx 0]
              (if (n.< num_labels idx)
                (exec (ffi.array_write idx
                                       (maybe.assume (list.nth idx labels))
                                       labels_array)
                  (recur (inc idx)))
                []))]
      (do_to visitor
        (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels_array)))))

(def: #export (try @from @to @handler exception)
  (-> //.Label //.Label //.Label (Type Class) Inst)
  (function (_ visitor)
    (do_to visitor
      (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (..class_name exception)))))

(def: #export (label @label)
  (-> //.Label Inst)
  (function (_ visitor)
    (do_to visitor
      (org/objectweb/asm/MethodVisitor::visitLabel @label))))

(def: #export (array elementT)
  (-> (Type Value) Inst)
  (case (type.primitive? elementT)
    (#.Left elementT)
    (ANEWARRAY elementT)

    (#.Right elementT)
    (NEWARRAY elementT)))

(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
  [(def: (<name> type)
     (-> (Type Primitive) Text)
     (`` (cond (~~ (template [<descriptor> <output>]
                     [(type@= <descriptor> type) <output>]
                     
                     [type.boolean <boolean>]
                     [type.byte    <byte>]
                     [type.short   <short>]
                     [type.int     <int>]
                     [type.long    <long>]
                     [type.float   <float>]
                     [type.double  <double>]
                     [type.char    <char>]))
               ## else
               (undefined))))]

  [primitive_wrapper
   box.boolean box.byte box.short box.int
   box.long box.float box.double box.char]
  [primitive_unwrap
   "booleanValue" "byteValue" "shortValue" "intValue"
   "longValue" "floatValue" "doubleValue" "charValue"]
  )

(def: #export (wrap type)
  (-> (Type Primitive) Inst)
  (let [wrapper (type.class (primitive_wrapper type) (list))]
    (INVOKESTATIC wrapper "valueOf" (type.method [(list type) wrapper (list)]))))

(def: #export (unwrap type)
  (-> (Type Primitive) Inst)
  (let [wrapper (type.class (primitive_wrapper type) (list))]
    (|>> (CHECKCAST wrapper)
         (INVOKEVIRTUAL wrapper (primitive_unwrap type) (type.method [(list) type (list)])))))

(def: #export (fuse insts)
  (-> (List Inst) Inst)
  (case insts
    #.Nil
    function.identity

    (#.Cons singleton #.Nil)
    singleton

    (#.Cons head tail)
    (function.compose (fuse tail) head)))