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

(;module:
  lux
  (lux (control monad)
       (data ["R" result]
             text/format)
       [math]
       [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
       [host #+ do-to])
  (luxc ["&" base]
        (lang ["la" analysis]
              ["ls" synthesis])
        ["&;" analyser]
        ["&;" synthesizer]
        (generator ["&;" common]
                   (host ["$" jvm]
                         (jvm ["$t" type]
                              ["$d" def]
                              ["$i" inst])))))

(host;import java.lang.Object)
(host;import java.lang.String)

(host;import java.lang.reflect.Field
  (get [Object] #try Object))

(host;import (java.lang.Class a)
  (getField [String] Field))

(host;import org.objectweb.asm.Opcodes
  (#static ACC_PUBLIC int)
  (#static ACC_SUPER int)
  (#static ACC_FINAL int)
  (#static ACC_STATIC int)
  (#static V1_6 int))

(host;import org.objectweb.asm.ClassWriter
  (#static COMPUTE_MAXS int)
  (new [int])
  (visit [int int String String String (Array String)] void)
  (visitEnd [] void)
  (toByteArray [] Byte-Array))

(def: #export runtime-name Text "LuxRuntime")
(def: #export function-name Text "LuxFunction")
(def: #export unit Text "\u0000")

(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: $Object-Array $;Type ($t;array +1 $Object))
(def: $String $;Type ($t;class "java.lang.String" (list)))
(def: #export $Stack $;Type ($t;array +1 $Object))
(def: #export $Tuple $;Type ($t;array +1 $Object))
(def: #export $Variant $;Type ($t;array +1 $Object))
(def: #export $Tag $;Type $t;int)
(def: #export $Flag $;Type $Object)
(def: #export $Datum $;Type $Object)

(def: logI
  $;Inst
  (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list)))
        printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))]
    (|>. outI ($i;string "LOG: ") (printI "print")
         outI $i;SWAP (printI "println"))))

(def: variant-method
  $;Method
  ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list)))

(def: variant-makeI
  $;Inst
  ($i;INVOKESTATIC runtime-name "variant_make" variant-method false))

(def: #export someI
  $;Inst
  (|>. ($i;int 1)
       ($i;string "")
       $i;DUP2_X1
       $i;POP2
       variant-makeI))

(def: #export noneI
  $;Inst
  (|>. ($i;int 0)
       $i;NULL
       ($i;string unit)
       variant-makeI))

(def: adt-methods
  $;Def
  (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE)
        store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE)
        store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)]
    (|>. ($d;method #$;Public $;staticM "variant_make"
                    ($t;method (list $t;int $Object $Object)
                               (#;Some $Variant)
                               (list))
                    (|>. ($i;array $Object +3)
                         store-tagI
                         store-flagI
                         store-valueI
                         $i;ARETURN)))))

(def: nat-methods
  $;Def
  (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))
        less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where)))
        $BigInteger ($t;class "java.math.BigInteger" (list))
        upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list))
        div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))
        upcastI ($i;INVOKESTATIC runtime-name "_toUnsignedBigInteger" upcast-method false)
        downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)]
    ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
    (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method
                    (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false)
                          discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where)))
                          prepare-upperI (|>. ($i;LLOAD +0) ($i;int 32) $i;LUSHR
                                              upcastI
                                              ($i;int 32) ($i;INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t;method (list $t;int) (#;Some $BigInteger) (list)) false))
                          prepare-lowerI (|>. ($i;LLOAD +0) ($i;int 32) $i;LSHL
                                              ($i;int 32)   $i;LUSHR
                                              upcastI)]
                      (<| $i;with-label (function [@simple])
                          (|>. (discernI @simple)
                               ## else
                               prepare-upperI
                               prepare-lowerI
                               ($i;INVOKEVIRTUAL "java.math.BigInteger" "add" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)
                               $i;ARETURN
                               ## then
                               ($i;label @simple)
                               ($i;LLOAD +0)
                               upcastI
                               $i;ARETURN))))
         ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
         ($d;method #$;Public $;staticM "compare_nat" compare-nat-method
                    (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)]
                      (|>. ($i;LLOAD +0) shiftI
                           ($i;LLOAD +2) shiftI
                           $i;LCMP
                           $i;IRETURN)))
         ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
         ($d;method #$;Public $;staticM "div_nat" div-method
                    (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where)))
                          is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where)))
                          small-division (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LDIV $i;LRETURN)
                          big-divisionI ($i;INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)]
                      (<| $i;with-label (function [@is-zero])
                          $i;with-label (function [@param-is-large])
                          $i;with-label (function [@subject-is-small])
                          (|>. (is-param-largeI @param-is-large)
                               ## Param is not too large
                               (is-subject-smallI @subject-is-small)
                               ## Param is small, but subject is large
                               ($i;LLOAD +0) upcastI
                               ($i;LLOAD +2) upcastI
                               big-divisionI downcastI $i;LRETURN
                               ## Both param and subject are small,
                               ## and can thus be divided normally.
                               ($i;label @subject-is-small)
                               small-division
                               ## Param is too large. Cannot simply divide.
                               ## Depending on the result of the
                               ## comparison, a result will be determined.
                               ($i;label @param-is-large)
                               ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @is-zero)
                               ## Greater-than or equals
                               ($i;long 1) $i;LRETURN
                               ## Less than
                               ($i;label @is-zero)
                               ($i;long 0) $i;LRETURN))))
         ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
         ($d;method #$;Public $;staticM "rem_nat" div-method
                    (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where)))
                          is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where)))
                          small-remainderI (|>. ($i;LLOAD +0) ($i;LLOAD +2) $i;LREM $i;LRETURN)
                          big-remainderI ($i;INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t;method (list $BigInteger) (#;Some $BigInteger) (list)) false)]
                      (<| $i;with-label (function [@large-number])
                          $i;with-label (function [@subject-is-smaller-than-param])
                          (|>. (is-subject-largeI @large-number)
                               (is-param-largeI @large-number)
                               small-remainderI

                               ($i;label @large-number)
                               ($i;LLOAD +0) ($i;LLOAD +2) (less-thanI @subject-is-smaller-than-param)
                               
                               ($i;LLOAD +0) upcastI
                               ($i;LLOAD +2) upcastI
                               big-remainderI downcastI $i;LRETURN
                               
                               ($i;label @subject-is-smaller-than-param)
                               ($i;LLOAD +0)
                               $i;LRETURN))))
         )))

(def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0)))

(def: frac-methods
  $;Def
  (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list))
                  (<| $i;with-label (function [@from])
                      $i;with-label (function [@to])
                      $i;with-label (function [@handler])
                      (|>. ($i;try @from @to @handler "java.lang.Exception")
                           ($i;label @from)
                           ($i;ALOAD +0)
                           ($i;INVOKESTATIC "java.lang.Double" "parseDouble" ($t;method (list $String) (#;Some $t;double) (list)) false)
                           ($i;wrap #$;Double)
                           someI
                           $i;ARETURN
                           ($i;label @to)
                           ($i;label @handler)
                           noneI
                           $i;ARETURN)))
       ($d;method #$;Public $;staticM "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list))
                  (let [swap2 (|>. $i;DUP2_X2 $i;POP2)
                        drop-excessI (|>. ($i;double 1.0) $i;DREM)
                        shiftI (|>. frac-shiftI $i;DMUL)]
                    (|>. ($i;DLOAD +0)
                         ## Get upper half
                         drop-excessI
                         shiftI
                         ## Make a copy, so the lower half can be extracted
                         $i;DUP2
                         ## Get lower half
                         drop-excessI
                         shiftI
                         ## Turn it into a deg
                         $i;D2L
                         ## Turn the upper half into deg too
                         swap2
                         $i;D2L
                         ## Combine both pieces
                         $i;LADD
                         ## FINISH
                         $i;LRETURN
                         )))
       ))

(def: deg-bits Nat +64)
(def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)))
(def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list)))

(def: deg-methods
  $;Def
  (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits.
        low-half (|>. ($i;int -1) $i;I2L $i;LAND)
        high-half (|>. ($i;int 32) $i;LUSHR)]
    (|>. ($d;method #$;Public $;staticM "mul_deg" deg-method
                    ## Based on: http://stackoverflow.com/a/31629280/6823464
                    (let [shift-downI (|>. ($i;int 32) $i;LUSHR)
                          low-leftI (|>. ($i;LLOAD +0) low-half)
                          high-leftI (|>. ($i;LLOAD +0) high-half)
                          low-rightI (|>. ($i;LLOAD +2) low-half)
                          high-rightI (|>. ($i;LLOAD +2) high-half)
                          bottomI (|>. low-leftI low-rightI $i;LMUL)
                          middleLI (|>. high-leftI low-rightI $i;LMUL)
                          middleRI (|>. low-leftI high-rightI $i;LMUL)
                          middleI (|>. middleLI middleRI $i;LADD)
                          topI (|>. high-leftI high-rightI $i;LMUL)]
                      (|>. bottomI shift-downI
                           middleI $i;LADD shift-downI
                           topI $i;LADD
                           $i;LRETURN)))
         ($d;method #$;Public $;staticM "count_leading_zeros" clz-method
                    (let [when-zeroI (function [@where] (|>. ($i;long 0) $i;LCMP ($i;IFEQ @where)))
                          shift-rightI (function [amount] (|>. ($i;int amount) $i;LUSHR))
                          decI (|>. ($i;int 1) $i;ISUB)]
                      (<| $i;with-label (function [@start])
                          $i;with-label (function [@done])
                          (|>. ($i;int 64)
                               ($i;label @start)
                               ($i;LLOAD +0) (when-zeroI @done)
                               ($i;LLOAD +0) (shift-rightI 1) ($i;LSTORE +0)
                               decI
                               ($i;GOTO @start)
                               ($i;label @done)
                               $i;IRETURN))))
         ($d;method #$;Public $;staticM "div_deg" deg-method
                    (<| $i;with-label (function [@same])
                        (let [subjectI ($i;LLOAD +0)
                              paramI ($i;LLOAD +2)
                              equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where)))
                              count-leading-zerosI ($i;INVOKESTATIC runtime-name "count_leading_zeros" clz-method false)
                              calc-max-shiftI (|>. subjectI count-leading-zerosI
                                                   paramI count-leading-zerosI
                                                   ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false)
                                                   ($i;ISTORE +4))
                              shiftI (|>. ($i;ILOAD +4) $i;LSHL)
                              imprecise-divisionI (|>. subjectI shiftI
                                                       paramI shiftI high-half
                                                       $i;LDIV)
                              scale-downI (|>. ($i;int 32) $i;LSHL)]
                          (|>. subjectI paramI
                               (equal?I @same)
                               ## Based on: http://stackoverflow.com/a/8510587/6823464
                               ## Shifting the operands as much as possible can help
                               ## avoid some loss of precision later.
                               calc-max-shiftI
                               imprecise-divisionI
                               scale-downI
                               $i;LRETURN
                               ($i;label @same)
                               ($i;long -1) ## ~= 1.0 Degrees
                               $i;LRETURN))))
         ($d;method #$;Public $;staticM "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list))
                    (let [highI (|>. ($i;LLOAD +0) high-half $i;L2D)
                          lowI (|>. ($i;LLOAD +0) low-half $i;L2D)
                          scaleI (|>. frac-shiftI $i;DDIV)]
                      (|>. highI scaleI
                           lowI scaleI scaleI
                           $i;DADD
                           $i;DRETURN)))
         )))

(def: pm-methods
  $;Def
  (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH)
        tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD)
        expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD)
        tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))]
    (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list))
                    (|>. ($i;NEW "java.lang.IllegalStateException")
                         $i;DUP
                         ($i;string "Invalid expression for pattern-matching.")
                         ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false)
                         $i;ATHROW))
         ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list))
                    (|>. ($i;int 2)
                         ($i;ANEWARRAY "java.lang.Object")
                         $i;DUP
                         ($i;int 0)
                         ($i;ALOAD +0)
                         $i;AASTORE
                         $i;DUP
                         ($i;int 1)
                         ($i;ALOAD +1)
                         $i;AASTORE
                         $i;ARETURN))
         ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list))
                    (|>. ($i;ALOAD +0)
                         ($i;int 0)
                         $i;AALOAD
                         ($i;CHECKCAST ($t;descriptor $Stack))
                         $i;ARETURN))
         ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list))
                    (|>. ($i;ALOAD +0)
                         ($i;int 1)
                         $i;AALOAD
                         $i;ARETURN))
         ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list))
                    (<| $i;with-label (function [@begin])
                        $i;with-label (function [@just-return])
                        $i;with-label (function [@then])
                        $i;with-label (function [@further])
                        $i;with-label (function [@shorten])
                        $i;with-label (function [@wrong])
                        (let [variant-partI (: (-> Nat $;Inst)
                                               (function [idx]
                                                 (|>. ($i;int (nat-to-int idx)) $i;AALOAD)))
                              tagI (: $;Inst
                                      (|>. (variant-partI +0) ($i;unwrap #$;Int)))
                              flagI (variant-partI +1)
                              datumI (variant-partI +2)
                              shortenI (|>. ($i;ALOAD +0) tagI ## Get tag
                                            ($i;ILOAD +1) $i;ISUB ## Shorten tag
                                            ($i;ALOAD +0) flagI ## Get flag
                                            ($i;ALOAD +0) datumI ## Get value
                                            variant-makeI ## Build sum
                                            $i;ARETURN)
                              update-tagI (|>. $i;ISUB ($i;ISTORE +1))
                              update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0))
                              wrongI (|>. $i;NULL $i;ARETURN)
                              return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)])
                        (|>. ($i;label @begin)
                             ($i;ILOAD +1) ## tag
                             ($i;ALOAD +0) tagI ## tag, sumT
                             $i;DUP2 ($i;IF_ICMPEQ @then)
                             $i;DUP2 ($i;IF_ICMPGT @further)
                             $i;DUP2 ($i;IF_ICMPLT @shorten)
                             ## $i;POP2
                             wrongI
                             ($i;label @then) ## tag, sumT
                             ($i;ALOAD +2) ## tag, sumT, wants-last?
                             ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last?
                             ($i;IF_ACMPEQ @just-return) ## tag, sumT
                             ($i;label @further) ## tag, sumT
                             ($i;ALOAD +0) flagI ## tag, sumT, last?
                             ($i;IFNULL @wrong) ## tag, sumT
                             update-tagI
                             update-variantI
                             ($i;GOTO @begin)
                             ($i;label @just-return) ## tag, sumT
                             ## $i;POP2
                             return-datumI
                             ($i;label @shorten) ## tag, sumT
                             ($i;ALOAD +2) ($i;IFNULL @wrong)
                             ## $i;POP2
                             shortenI
                             ($i;label @wrong) ## tag, sumT
                             ## $i;POP2
                             wrongI)))
         ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list))
                    (<| $i;with-label (function [@begin])
                        $i;with-label (function [@not-recursive])
                        (let [updated-idxI (|>. $i;SWAP $i;ISUB)])
                        (|>. ($i;label @begin)
                             tuple-sizeI
                             expected-last-sizeI
                             $i;DUP2 ($i;IF_ICMPGT @not-recursive)
                             ## Recursive
                             updated-idxI ($i;ISTORE +1)
                             tuple-tailI ($i;ASTORE +0)
                             ($i;GOTO @begin)
                             ($i;label @not-recursive)
                             ## $i;POP2
                             tuple-elemI
                             $i;ARETURN)))
         ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list))
                    (<| $i;with-label (function [@begin])
                        $i;with-label (function [@tail])
                        $i;with-label (function [@slice])
                        (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB)
                              sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI
                                          ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))])
                        (|>. ($i;label @begin)
                             tuple-sizeI
                             expected-last-sizeI
                             $i;DUP2 ($i;IF_ICMPEQ @tail)
                             ($i;IF_ICMPGT @slice)
                             ## Must recurse
                             tuple-tailI ($i;ASTORE +0)
                             updated-idxI ($i;ISTORE +1)
                             ($i;GOTO @begin)
                             ($i;label @slice)
                             sliceI
                             $i;ARETURN
                             ($i;label @tail)
                             ## $i;POP2
                             tuple-elemI
                             $i;ARETURN)))
         )))

(def: #export generate
  (Lux &common;Bytecode)
  (do Monad<Lux>
    [_ (wrap [])
     #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list)
                              (|>. adt-methods
                                   nat-methods
                                   frac-methods
                                   deg-methods
                                   pm-methods))]
     _ (&common;store-class runtime-name bytecode)]
    (wrap bytecode)))