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

(;module:
  [lux #- char]
  (lux (control monad
                ["p" parser])
       (data text/format
             ["R" result]
             (coll [list "L/" Functor<List>]))
       [host #+ do-to]
       [macro]
       (macro [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))

(with-expansions [<primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
                                       T_BYTE T_SHORT T_INT T_LONG)
                  <stack> (declare DUP 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)
                  <var> (declare ILOAD LLOAD DLOAD ALOAD
                                 ISTORE LSTORE ASTORE)
                  <arithmethic> (declare IADD ISUB
                                         LADD LSUB LMUL LDIV LREM
                                         LCMP
                                         DADD DSUB DMUL DDIV DREM
                                         DCMPG DCMPL)
                  <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
  (host;import org.objectweb.asm.Opcodes
    <primitive>

    (#static CHECKCAST int)
    (#static NEW int)
    (#static NEWARRAY int)
    (#static ANEWARRAY int)
    
    <stack>
    <jump>

    (#static ACONST_NULL int)
    
    <var>
    
    (#static LAND int)
    (#static LOR int)
    (#static LXOR int)
    (#static LSHL int)
    (#static LSHR int)
    (#static LUSHR int)

    <arithmethic>

    (#static I2L int)
    (#static L2I int)
    (#static L2D int)
    (#static D2L int)
    (#static I2C int)

    (#static AALOAD int)
    (#static AASTORE int)
    (#static ARRAYLENGTH int)
    
    (#static GETSTATIC int)
    (#static PUTSTATIC int)
    (#static GETFIELD int)
    (#static PUTFIELD int)
    
    (#static INVOKESTATIC int)
    (#static INVOKESPECIAL int)
    (#static INVOKEVIRTUAL int)

    (#static ATHROW int)

    <return>
    ))

(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
  (Lux Label)
  (function [compiler]
    (#R;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>)]))))]

  ## Stack
  [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP]

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

  ## Integer arithmetic
  [IADD] [ISUB]
  
  ## Long arithmethic
  [LADD] [LSUB] [LMUL] [LDIV] [LREM]
  [LCMP]

  ## Double arithmetic
  [DADD] [DSUB] [DMUL] [DDIV] [DREM]
  [DCMPG] [DCMPL]

  ## Conversions
  [I2L] [L2I] [L2D] [D2L] [I2C]

  ## Array
  [AALOAD] [AASTORE] [ARRAYLENGTH]

  ## Exceptions
  [ATHROW]

  ## 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]
  [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_SHORT
                                                      #$;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]
  )

(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
                                        (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 size)
  (-> $;Type Nat $;Inst)
  (case type
    (#$;Primitive prim)
    (|>. (int (nat-to-int size))
         (NEWARRAY prim))

    (#$;Generic generic)
    (let [elem-class (case generic
                       (#$;Class class params)
                       ($t;binary-name class)

                       _
                       ($t;binary-name "java.lang.Object"))]
      (|>. (int (nat-to-int size))
           (ANEWARRAY elem-class)))

    _
    (|>. (int (nat-to-int size))
         (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)
    (. head (fuse tail))))