path: root/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux

(.using
 [library
  [lux {"-" Type Label Primitive try}
   [abstract
    [monad {"+" do}]
    ["[0]" enum]]
   [data
    [binary {"+" Binary}]
    ["[0]" product]
    [text
     ["%" format {"+" format}]]
    [collection
     ["[0]" list ("[1]@[0]" functor)]
     ["[0]" sequence]
     ["[0]" set]]]
   ["[0]" math
    [number
     ["n" nat]]]
   [target
    [jvm
     ["[0]" type {"+" Type}
      ["[0]" category {"+" Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method}]
      ["[0]" reflection]]]]
   [tool
    [compiler
     [arity {"+" Arity}]
     ["[0]" phase]
     [language
      [lux
       ["[0]" synthesis]
       ["[0]" generation]]]
     [meta
      [archive {"+" Output}
       ["[0]" artifact]
       ["[0]" registry {"+" Registry}]
       ["[0]" unit]]]]]]]
 [luxc
  [lang
   [host
    ["$" jvm {"+" Label Inst Def Operation}
     ["$d" def]
     ["_" inst]]]]]
 ["[0]" // {"+" ByteCode}])

(def: $Text (type.class "java.lang.String" (list)))
(def: .public $Lefts type.int)
(def: .public $Right? (type.class "java.lang.Object" (list)))
(def: .public $Value (type.class "java.lang.Object" (list)))
(def: .public $Index type.int)
(def: .public $Stack (type.array $Value))
(def: $Throwable (type.class "java.lang.Throwable" (list)))

(def: nullary_init_methodT
  (type.method [(list) (list) type.void (list)]))

(def: throw_methodT
  (type.method [(list) (list) type.void (list)]))

(def: .public logI
  Inst
  (let [PrintStream (type.class "java.io.PrintStream" (list))
        outI (_.GETSTATIC (type.class "java.lang.System" (list)) "out" PrintStream)
        printI (function (_ method)
                 (_.INVOKEVIRTUAL PrintStream method (type.method [(list) (list $Value) type.void (list)])))]
    (|>> outI (_.string "LOG: ") (printI "print")
         outI _.SWAP (printI "println"))))

(def: variant_method
  (type.method [(list) (list $Lefts $Right? $Value) //.$Variant (list)]))

(def: .public variantI
  Inst
  (_.INVOKESTATIC //.$Runtime "variant_make" variant_method))

(def: .public leftI
  Inst
  (|>> _.ICONST_0
       _.NULL
       _.DUP2_X1
       _.POP2
       variantI))

(def: .public rightI
  Inst
  (|>> _.ICONST_0
       (_.string "")
       _.DUP2_X1
       _.POP2
       variantI))

(def: .public someI Inst rightI)

(def: .public noneI
  Inst
  (|>> _.ICONST_0
       _.NULL
       (_.string synthesis.unit)
       variantI))

(def: (tryI unsafeI)
  (-> Inst Inst)
  (<| _.with_label (function (_ @from))
      _.with_label (function (_ @to))
      _.with_label (function (_ @handler))
      (|>> (_.try @from @to @handler (type.class "java.lang.Exception" (list)))
           (_.label @from)
           unsafeI
           someI
           _.ARETURN
           (_.label @to)
           (_.label @handler)
           noneI
           _.ARETURN)))

(def: .public partials_field Text "partials")
(def: .public apply_method Text "apply")
(def: .public num_apply_variants Nat 8)

(def: .public (apply_signature arity)
  (-> Arity (Type Method))
  (type.method [(list) (list.repeated arity $Value) $Value (list)]))

(def: adt_methods
  Def
  (let [store_leftsI (|>> _.DUP _.ICONST_0 (_.ILOAD 0) (_.wrap type.int) _.AASTORE)
        store_flagI (|>> _.DUP _.ICONST_1 (_.ALOAD 1) _.AASTORE)
        store_valueI (|>> _.DUP _.ICONST_2 (_.ALOAD 2) _.AASTORE)]
    (|>> ($d.method {$.#Public} $.staticM "variant_make"
                    (type.method [(list) (list $Lefts $Right? $Value) //.$Variant (list)])
                    (|>> _.ICONST_3
                         (_.ANEWARRAY $Value)
                         store_leftsI
                         store_flagI
                         store_valueI
                         _.ARETURN)))))

(def: frac_methods
  Def
  (|>> ($d.method {$.#Public} $.staticM "decode_frac" (type.method [(list) (list $Text) //.$Variant (list)])
                  (tryI
                   (|>> (_.ALOAD 0)
                        (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "parseDouble" (type.method [(list) (list $Text) type.double (list)]))
                        (_.wrap type.double))))
       ))

(def: (illegal_state_exception message)
  (-> Text Inst)
  (let [IllegalStateException (type.class "java.lang.IllegalStateException" (list))]
    (|>> (_.NEW IllegalStateException)
         _.DUP
         (_.string message)
         (_.INVOKESPECIAL IllegalStateException "<init>" (type.method [(list) (list $Text) type.void (list)])))))

(def: pm_methods
  Def
  (let [tuple_sizeI (|>> (_.ALOAD 0)
                         _.ARRAYLENGTH)
        last_rightI (|>> tuple_sizeI
                         _.ICONST_1
                         _.ISUB)
        leftsI (_.ILOAD 1)
        left_indexI leftsI
        sub_leftsI (|>> leftsI
                        last_rightI
                        _.ISUB)
        sub_tupleI (|>> (_.ALOAD 0)
                        last_rightI
                        _.AALOAD
                        (_.CHECKCAST //.$Tuple))
        recurI (is (-> Label Inst)
                   (function (_ @loop)
                     (|>> sub_leftsI (_.ISTORE 1)
                          sub_tupleI (_.ASTORE 0)
                          (_.GOTO @loop))))]
    (|>> ($d.method {$.#Public} $.staticM "pm_fail" throw_methodT
                    (|>> (illegal_state_exception "Invalid expression for pattern-matching.")
                         _.ATHROW))
         ($d.method {$.#Public} $.staticM "apply_fail" throw_methodT
                    (|>> (illegal_state_exception "Error while applying function.")
                         _.ATHROW))
         ($d.method {$.#Public} $.staticM "pm_push" (type.method [(list) (list $Stack $Value) $Stack (list)])
                    (|>> _.ICONST_2
                         (_.ANEWARRAY $Value)
                         _.DUP
                         _.ICONST_1
                         (_.ALOAD 0)
                         _.AASTORE
                         _.DUP
                         _.ICONST_0
                         (_.ALOAD 1)
                         _.AASTORE
                         _.ARETURN))
         ($d.method {$.#Public} $.staticM "pm_variant" (type.method [(list) (list //.$Variant $Lefts $Right?) $Value (list)])
                    (<| _.with_label (function (_ @loop))
                        _.with_label (function (_ @perfect_match!))
                        _.with_label (function (_ @lefts_match!))
                        _.with_label (function (_ @maybe_nested))
                        _.with_label (function (_ @mismatch!))
                        (let [$variant (_.ALOAD 0)
                              $lefts (_.ILOAD 1)
                              $right? (_.ALOAD 2)
                              
                              variant_partI (is (-> Nat Inst)
                                                (function (_ idx)
                                                  (|>> (_.int (.int idx)) _.AALOAD)))
                              ::lefts (is Inst
                                          (|>> (variant_partI 0)
                                               (_.unwrap type.int)))
                              ::right? (variant_partI 1)
                              ::value (variant_partI 2)
                              
                              not_found _.NULL

                              super_nested_lefts (|>> _.SWAP ... variant::lefts, lefts
                                                      _.ISUB
                                                      (_.int +1)
                                                      _.ISUB)
                              super_nested (|>> super_nested_lefts ... super_lefts
                                                $variant ::right? ... super_lefts, super_right?
                                                $variant ::value ... super_lefts, super_right?, super_value
                                                ..variantI)
                              
                              update_$variant (|>> $variant ::value
                                                   (_.CHECKCAST //.$Variant)
                                                   (_.ASTORE 0))
                              update_$lefts (|>> _.ISUB
                                                 (_.int +1)
                                                 _.ISUB)
                              iterate! (is (-> Label Inst)
                                           (function (_ @loop)
                                             (|>> update_$variant
                                                  update_$lefts
                                                  (_.GOTO @loop))))])
                        (|>> $lefts ... lefts
                             (_.label @loop)
                             $variant ::lefts ... lefts, variant::lefts
                             _.DUP2 (_.IF_ICMPEQ @lefts_match!) ... lefts, variant::lefts
                             _.DUP2 (_.IF_ICMPGT @maybe_nested) ... lefts, variant::lefts
                             $right? (_.IFNULL @mismatch!) ... lefts, variant::lefts
                             super_nested ... super_variant
                             _.ARETURN
                             ...........................
                             ...... @lefts_match! ......
                             ...........................
                             (_.label @lefts_match!) ... lefts, variant::lefts
                             $right? ... lefts, variant::lefts, right?
                             $variant ::right? ... lefts, variant::lefts, right?, variant::right?
                             (_.IF_ACMPEQ @perfect_match!) ... lefts, variant::lefts
                             ........................
                             ...... @mismatch! ......
                             ........................
                             (_.label @mismatch!) ... lefts, variant::lefts
                             ... _.POP2
                             not_found
                             _.ARETURN
                             (_.label @maybe_nested) ... lefts, variant::lefts
                             $variant ::right? ... lefts, variant::lefts, variant::right?
                             (_.IFNULL @mismatch!) ... lefts, variant::lefts
                             (iterate! @loop)
                             .............................
                             ...... @perfect_match! ......
                             .............................
                             (_.label @perfect_match!) ... lefts, variant::lefts
                             ... _.POP2
                             $variant ::value
                             _.ARETURN)))
         ($d.method {$.#Public} $.staticM "tuple_left" (type.method [(list) (list //.$Tuple $Index) $Value (list)])
                    (<| _.with_label (function (_ @loop))
                        _.with_label (function (_ @recursive))
                        (let [left_accessI (|>> (_.ALOAD 0) left_indexI _.AALOAD)])
                        (|>> (_.label @loop)
                             leftsI last_rightI (_.IF_ICMPGE @recursive)
                             left_accessI
                             _.ARETURN
                             (_.label @recursive)
                             ... Recursive
                             (recurI @loop))))
         ($d.method {$.#Public} $.staticM "tuple_right" (type.method [(list) (list //.$Tuple $Index) $Value (list)])
                    (<| _.with_label (function (_ @loop))
                        _.with_label (function (_ @not_tail))
                        _.with_label (function (_ @slice))
                        (let [right_indexI (|>> leftsI
                                                _.ICONST_1
                                                _.IADD)
                              right_accessI (|>> (_.ALOAD 0)
                                                 _.SWAP
                                                 _.AALOAD)
                              sub_rightI (|>> (_.ALOAD 0)
                                              right_indexI
                                              tuple_sizeI
                                              (_.INVOKESTATIC (type.class "java.util.Arrays" (list)) "copyOfRange"
                                                              (type.method [(list)
                                                                            (list //.$Tuple $Index $Index)
                                                                            //.$Tuple
                                                                            (list)])))])
                        (|>> (_.label @loop)
                             last_rightI right_indexI
                             _.DUP2 (_.IF_ICMPNE @not_tail)
                             ... _.POP
                             right_accessI
                             _.ARETURN
                             (_.label @not_tail)
                             (_.IF_ICMPGT @slice)
                             ... Must recurse
                             (recurI @loop)
                             (_.label @slice)
                             sub_rightI
                             _.ARETURN
                             )))
         )))

(def: .public try
  (type.method [(list) (list //.$Function) //.$Variant (list)]))

(def: io_methods
  Def
  (let [StringWriter (type.class "java.io.StringWriter" (list))
        PrintWriter (type.class "java.io.PrintWriter" (list))
        string_writerI (|>> (_.NEW StringWriter)
                            _.DUP
                            (_.INVOKESPECIAL StringWriter "<init>" nullary_init_methodT))
        print_writerI (|>> (_.NEW PrintWriter)
                           _.SWAP
                           _.DUP2
                           _.POP
                           _.SWAP
                           (_.boolean true)
                           (_.INVOKESPECIAL PrintWriter "<init>" (type.method [(list) (list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)]))
                           )]
    (|>> ($d.method {$.#Public} $.staticM "try" ..try
                    (<| _.with_label (function (_ @from))
                        _.with_label (function (_ @to))
                        _.with_label (function (_ @handler))
                        (|>> (_.try @from @to @handler $Throwable)
                             (_.label @from)
                             (_.ALOAD 0)
                             _.NULL
                             (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature 1))
                             rightI
                             _.ARETURN
                             (_.label @to)
                             (_.label @handler)
                             string_writerI ... TW
                             _.DUP2 ... TWTW
                             print_writerI ... TWTP
                             (_.INVOKEVIRTUAL $Throwable "printStackTrace" (type.method [(list) (list (type.class "java.io.PrintWriter" (list))) type.void (list)])) ... TW
                             (_.INVOKEVIRTUAL StringWriter "toString" (type.method [(list) (list) $Text (list)])) ... TS
                             _.SWAP _.POP leftI
                             _.ARETURN)))
         )))

(def: reflection
  (All (_ category)
    (-> (Type (<| Return' Value' category)) Text))
  (|>> type.reflection reflection.reflection))

(def: runtime_id
  0)

(def: translate_runtime
  (Operation [artifact.ID (Maybe Text) Binary])
  (let [runtime_class (..reflection //.$Runtime)
        bytecode ($d.class {$.#V1_6} {$.#Public} $.finalC runtime_class (list) (type.class "java.lang.Object" (list)) (list)
                           (|>> adt_methods
                                frac_methods
                                pm_methods
                                io_methods))
        directive [runtime_class bytecode]]
    (do phase.monad
      [_ (generation.execute! directive)
       _ (generation.save! ..runtime_id {.#None} directive)]
      (in [..runtime_id {.#None} bytecode]))))

(def: function_id
  1)

(def: translate_function
  (Operation [artifact.ID (Maybe Text) Binary])
  (let [applyI (|> (enum.range n.enum 2 num_apply_variants)
                   (list@each (function (_ arity)
                                ($d.method {$.#Public} $.noneM apply_method (apply_signature arity)
                                           (let [preI (|> (enum.range n.enum 0 (-- arity))
                                                          (list@each _.ALOAD)
                                                          _.fuse)]
                                             (|>> preI
                                                  (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature (-- arity)))
                                                  (_.CHECKCAST //.$Function)
                                                  (_.ALOAD arity)
                                                  (_.INVOKEVIRTUAL //.$Function apply_method (apply_signature 1))
                                                  _.ARETURN)))))
                   (list& ($d.abstract_method {$.#Public} $.noneM apply_method (apply_signature 1)))
                   $d.fuse)
        $Object (type.class "java.lang.Object" (list))
        function_class (..reflection //.$Function)
        bytecode ($d.abstract {$.#V1_6} {$.#Public} $.noneC function_class (list) $Object (list)
                              (|>> ($d.field {$.#Public} $.finalF partials_field type.int)
                                   ($d.method {$.#Public} $.noneM "<init>" (type.method [(list) (list type.int) type.void (list)])
                                              (|>> (_.ALOAD 0)
                                                   (_.INVOKESPECIAL $Object "<init>" nullary_init_methodT)
                                                   (_.ALOAD 0)
                                                   (_.ILOAD 1)
                                                   (_.PUTFIELD //.$Function partials_field type.int)
                                                   _.RETURN))
                                   applyI))
        directive [function_class bytecode]]
    (do phase.monad
      [_ (generation.execute! directive)
       _ (generation.save! ..function_id {.#None} directive)]
      (in [..function_id {.#None} bytecode]))))

(def: .public translate
  (Operation [Registry Output])
  (do phase.monad
    [runtime_payload ..translate_runtime
     ... function_payload ..translate_function
     ]
    (in [(|> registry.empty
             (registry.resource true unit.none)
             product.right
             ... (registry.resource true unit.none)
             ... product.right
             )
         (sequence.sequence runtime_payload
                            ... function_payload
                            )])))