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

(.module:
  [lux (#- Type int char)
   ["." host (#+ import: do-to)]
   [abstract
    [monad (#+ do)]]
   [control
    ["." function]
    ["p" parser
     ["s" code]]]
   [data
    ["." maybe]
    ["." error]
    [text
     format]
    [collection
     ["." list ("#@." functor)]]]
   [macro
    ["." code]
    [syntax (#+ syntax:)]]
   [target
    [jvm
     ["." type (#+ Primitive Method Type)]]]
   [tool
    [compiler
     [phase (#+ Operation)]]]]
  ["." // (#+ Inst)])

## [Host]
(import: #long java/lang/Object)
(import: #long 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 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))
      ))

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

(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
  (All [s] (Operation s Label))
  (function (_ state)
    (#error.Success [state (Label::new)])))

(def: #export (with-label action)
  (-> (-> Label Inst) Inst)
  (action (Label::new)))

(template [<name> <type> <prepare>]
  [(def: #export (<name> value)
     (-> <type> Inst)
     (function (_ visitor)
       (do-to visitor
         (MethodVisitor::visitLdcInsn (<prepare> value)))))]

  [boolean Bit  function.identity]
  [int     Int  host.long-to-int]
  [long    Int  function.identity]
  [double  Frac function.identity]
  [char    Nat  (|>> .int host.long-to-int host.int-to-char)]
  [string  Text function.identity]
  )

(syntax: (prefix {base s.local-identifier})
  (wrap (list (` ((~ (code.local-identifier (format "Opcodes::" base))))))))

(def: #export NULL
  Inst
  (function (_ visitor)
    (do-to visitor
      (MethodVisitor::visitInsn (prefix ACONST_NULL)))))

(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]
  )

(template [<name>]
  [(def: #export (<name> register)
     (-> Nat Inst)
     (function (_ visitor)
       (do-to visitor
         (MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))]

  [ILOAD] [LLOAD] [DLOAD] [ALOAD]
  [ISTORE] [LSTORE] [ASTORE]
  )

(template [<name> <inst>]
  [(def: #export (<name> class field type)
     (-> Text Text Type Inst)
     (function (_ visitor)
       (do-to visitor
         (MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]

  [GETSTATIC Opcodes::GETSTATIC]
  [PUTSTATIC Opcodes::PUTSTATIC]
  
  [PUTFIELD  Opcodes::PUTFIELD]
  [GETFIELD  Opcodes::GETFIELD]
  )

(template [<name> <inst>]
  [(def: #export (<name> class)
     (-> Text Inst)
     (function (_ visitor)
       (do-to visitor
         (MethodVisitor::visitTypeInsn (<inst>) (type.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
                                     #type.Boolean (Opcodes::T_BOOLEAN)
                                     #type.Byte    (Opcodes::T_BYTE)
                                     #type.Short   (Opcodes::T_SHORT)
                                     #type.Int     (Opcodes::T_INT)
                                     #type.Long    (Opcodes::T_LONG)
                                     #type.Float   (Opcodes::T_FLOAT)
                                     #type.Double  (Opcodes::T_DOUBLE)
                                     #type.Char    (Opcodes::T_CHAR))))))

(template [<name> <inst>]
  [(def: #export (<name> class method-name method-signature interface?)
     (-> Text Text Method Bit Inst)
     (function (_ visitor)
       (do-to visitor
         (MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]

  [INVOKESTATIC    Opcodes::INVOKESTATIC]
  [INVOKEVIRTUAL   Opcodes::INVOKEVIRTUAL]
  [INVOKESPECIAL   Opcodes::INVOKESPECIAL]
  [INVOKEINTERFACE Opcodes::INVOKEINTERFACE]
  )

(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_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
  [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 (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 (type.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
    (#type.Primitive prim)
    (NEWARRAY prim)

    (#type.Generic generic)
    (let [elem-class (case generic
                       (#type.Class class params)
                       (type.binary-name class)

                       _
                       (type.binary-name "java.lang.Object"))]
      (ANEWARRAY elem-class))

    _
    (ANEWARRAY (type.descriptor type))))

(def: (primitive-wrapper type)
  (-> Primitive Text)
  (case type
    #type.Boolean "java.lang.Boolean"
    #type.Byte    "java.lang.Byte"
    #type.Short   "java.lang.Short"
    #type.Int     "java.lang.Integer"
    #type.Long    "java.lang.Long"
    #type.Float   "java.lang.Float"
    #type.Double  "java.lang.Double"
    #type.Char    "java.lang.Character"))

(def: (primitive-unwrap type)
  (-> Primitive Text)
  (case type
    #type.Boolean "booleanValue"
    #type.Byte    "byteValue"
    #type.Short   "shortValue"
    #type.Int     "intValue"
    #type.Long    "longValue"
    #type.Float   "floatValue"
    #type.Double  "doubleValue"
    #type.Char    "charValue"))

(def: #export (wrap type)
  (-> Primitive Inst)
  (let [class (primitive-wrapper type)]
    (|>> (INVOKESTATIC class "valueOf"
                       (type.method (list (#type.Primitive type))
                                    (#.Some (type.class class (list)))
                                    (list))
                       #0))))

(def: #export (unwrap type)
  (-> Primitive Inst)
  (let [class (primitive-wrapper type)]
    (|>> (CHECKCAST class)
         (INVOKEVIRTUAL class (primitive-unwrap type)
                        (type.method (list) (#.Some (#type.Primitive type)) (list))
                        #0))))

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

    (#.Cons singleton #.Nil)
    singleton

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