path: root/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux

(.module:
  lux
  (lux (control [monad #+ do]
                ["p" parser]
                ["ex" exception #+ exception:])
       (data ["e" error]
             [text]
             text/format
             (coll [list "list/" Functor<List>]
                   (dictionary ["dict" unordered #+ Dict])))
       [macro #+ with-gensyms]
       (macro [code]
              ["s" syntax #+ syntax:])
       [host]
       ["//" lang]
       (lang ["//." reference #+ Register]
             ["//." synthesis #+ Synthesis]
             ["//." extension]))
  (luxc (lang [".L" host]
              (host ["$" jvm]
                    (jvm ["$t" type]
                         ["$d" def]
                         ["$i" inst]))))
  (/// [".T" runtime]
       [".T" case]
       [".T" function]
       [".T" loop]))

(host.import: java/lang/Double
  (#static MIN_VALUE Double)
  (#static MAX_VALUE Double))

## [Types]
(type: #export Translator
  (-> Synthesis (Meta $.Inst)))

(type: #export Proc
  (-> Translator (List Synthesis) (Meta $.Inst)))

(type: #export Bundle
  (Dict Text Proc))

(syntax: (Vector {size s.nat} elemT)
  (wrap (list (` [(~+ (list.repeat size elemT))]))))

(type: #export Nullary (-> (Vector +0 $.Inst) $.Inst))
(type: #export Unary   (-> (Vector +1 $.Inst) $.Inst))
(type: #export Binary  (-> (Vector +2 $.Inst) $.Inst))
(type: #export Trinary (-> (Vector +3 $.Inst) $.Inst))
(type: #export Variadic (-> (List $.Inst) $.Inst))

## [Utils]
(def: $Object $.Type ($t.class "java.lang.Object" (list)))
(def: $Object-Array $.Type ($t.array +1 $Object))
(def: $Variant $.Type ($t.array +1 $Object))
(def: $String $.Type ($t.class "java.lang.String" (list)))
(def: $CharSequence $.Type ($t.class "java.lang.CharSequence" (list)))
(def: $Function $.Type ($t.class hostL.function-class (list)))

(def: #export (install name unnamed)
  (-> Text (-> Text Proc)
      (-> Bundle Bundle))
  (dict.put name (unnamed name)))

(def: #export (prefix prefix bundle)
  (-> Text Bundle Bundle)
  (|> bundle
      dict.entries
      (list/map (function (_ [key val]) [(format prefix " " key) val]))
      (dict.from-list text.Hash<Text>)))

(def: (wrong-arity proc expected actual)
  (-> Text Nat Nat Text)
  (format "Wrong number of arguments for " (%t proc) "\n"
          "Expected: " (|> expected .int %i) "\n"
          "  Actual: " (|> actual .int %i)))

(syntax: (arity: {name s.local-identifier} {arity s.nat})
  (with-gensyms [g!_ g!proc g!name g!translate g!inputs]
    (do @
      [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
      (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc))
                       (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst)
                           (-> Text ..Proc))
                       (function ((~ g!_) (~ g!name))
                         (function ((~ g!_) (~ g!translate) (~ g!inputs))
                           (case (~ g!inputs)
                             (^ (list (~+ g!input+)))
                             (do macro.Monad<Meta>
                               [(~+ (|> g!input+
                                        (list/map (function (_ g!input)
                                                    (list g!input (` ((~ g!translate) (~ g!input))))))
                                        list.concat))]
                               ((~' wrap) ((~ g!proc) [(~+ g!input+)])))

                             (~' _)
                             (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs))))))))))))))

(arity: nullary +0)
(arity: unary +1)
(arity: binary +2)
(arity: trinary +3)

(def: #export (variadic proc)
  (-> Variadic (-> Text Proc))
  (function (_ proc-name)
    (function (_ translate inputsS)
      (do macro.Monad<Meta>
        [inputsI (monad.map @ translate inputsS)]
        (wrap (proc inputsI))))))

## [Instructions]
(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long)))
(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I))

(def: (array-writeI arrayI idxI elemI)
  (-> $.Inst $.Inst $.Inst
      $.Inst)
  (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
       $i.DUP
       idxI jvm-intI
       elemI
       $i.AASTORE))

(def: (predicateI tester)
  (-> (-> $.Label $.Inst)
      $.Inst)
  (<| $i.with-label (function (_ @then))
      $i.with-label (function (_ @end))
      (|>> (tester @then)
           ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
           ($i.GOTO @end)
           ($i.label @then)
           ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
           ($i.label @end)
           )))

(def: unitI $.Inst ($i.string hostL.unit))

## [Procedures]
## [[Lux]]
(def: (lux//is [leftI rightI])
  Binary
  (|>> leftI
       rightI
       (predicateI $i.IF_ACMPEQ)))

(def: (lux//if [testI thenI elseI])
  Trinary
  (caseT.translate-if testI thenI elseI))

(def: (lux//try riskyI)
  Unary
  (|>> riskyI
       ($i.CHECKCAST hostL.function-class)
       ($i.INVOKESTATIC hostL.runtime-class "try"
                        ($t.method (list $Function) (#.Some $Object-Array) (list))
                        #0)))

(exception: #export (Wrong-Syntax {message Text})
  message)

(def: #export (wrong-syntax procedure args)
  (-> Text (List Synthesis) Text)
  (format "Procedure: " procedure "\n"
          "Arguments: " (%code (code.tuple args))))

(def: lux//loop
  (-> Text Proc)
  (function (_ proc-name)
    (function (_ translate inputsS)
      (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any))
        (#e.Success [offset initsS+ bodyS])
        (loopT.translate-loop translate offset initsS+ bodyS)

        (#e.Error error)
        (//.throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
      )))

(def: lux//recur
  (-> Text Proc)
  (function (_ proc-name)
    (function (_ translate inputsS)
      (loopT.translate-recur translate inputsS))))

## [[Bits]]
(do-template [<name> <op>]
  [(def: (<name> [inputI maskI])
     Binary
     (|>> inputI ($i.unwrap #$.Long)
          maskI ($i.unwrap #$.Long)
          <op> ($i.wrap #$.Long)))]

  [bit//and $i.LAND]
  [bit//or  $i.LOR]
  [bit//xor $i.LXOR]
  )

(do-template [<name> <op>]
  [(def: (<name> [inputI shiftI])
     Binary
     (|>> inputI ($i.unwrap #$.Long)
          shiftI jvm-intI
          <op>
          ($i.wrap #$.Long)))]

  [bit//left-shift             $i.LSHL]
  [bit//arithmetic-right-shift $i.LSHR]
  [bit//logical-right-shift    $i.LUSHR]
  )

## [[Arrays]]
(def: (array//new lengthI)
  Unary
  (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.Object"))))

(def: (array//get [arrayI idxI])
  Binary
  (<| $i.with-label (function (_ @is-null))
      $i.with-label (function (_ @end))
      (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
           idxI jvm-intI
           $i.AALOAD
           $i.DUP
           ($i.IFNULL @is-null)
           runtimeT.someI
           ($i.GOTO @end)
           ($i.label @is-null)
           $i.POP
           runtimeT.noneI
           ($i.label @end))))

(def: (array//put [arrayI idxI elemI])
  Trinary
  (array-writeI arrayI idxI elemI))

(def: (array//remove [arrayI idxI])
  Binary
  (array-writeI arrayI idxI $i.NULL))

(def: (array//size arrayI)
  Unary
  (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
       $i.ARRAYLENGTH
       lux-intI))

## [[Numbers]]
(def: nat-method
  $.Method
  ($t.method (list $t.long $t.long) (#.Some $t.long) (list)))

(do-template [<name> <const> <type>]
  [(def: (<name> _)
     Nullary
     (|>> <const> ($i.wrap <type>)))]

  [frac//smallest          ($i.double Double::MIN_VALUE)            #$.Double]
  [frac//min               ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double]
  [frac//max               ($i.double Double::MAX_VALUE)            #$.Double]
  )

(do-template [<name> <type> <op>]
  [(def: (<name> [subjectI paramI])
     Binary
     (|>> subjectI ($i.unwrap <type>)
          paramI ($i.unwrap <type>)
          <op>
          ($i.wrap <type>)))]

  [int//add        #$.Long   $i.LADD]
  [int//sub        #$.Long   $i.LSUB]
  [int//mul        #$.Long   $i.LMUL]
  [int//div        #$.Long   $i.LDIV]
  [int//rem        #$.Long   $i.LREM]
  
  [frac//add       #$.Double $i.DADD]
  [frac//sub       #$.Double $i.DSUB]
  [frac//mul       #$.Double $i.DMUL]
  [frac//div       #$.Double $i.DDIV]
  [frac//rem       #$.Double $i.DREM]
  )

(do-template [<eq> <lt> <unwrap> <cmp>]
  [(do-template [<name> <reference>]
     [(def: (<name> [subjectI paramI])
        Binary
        (|>> subjectI <unwrap>
             paramI <unwrap>
             <cmp>
             ($i.int <reference>)
             (predicateI $i.IF_ICMPEQ)))]
     [<eq>  0]
     [<lt> -1])]

  [int//eq  int//lt  ($i.unwrap #$.Long)   $i.LCMP]
  [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG]
  )

(do-template [<name> <prepare> <transform>]
  [(def: (<name> inputI)
     Unary
     (|>> inputI <prepare> <transform>))]

  [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)]
  [int//char ($i.unwrap #$.Long)
   ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) #0)))]

  [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)]
  [frac//encode ($i.unwrap #$.Double)
   ($i.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) #0)]
  [frac//decode ($i.CHECKCAST "java.lang.String")
   ($i.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) #0)]
  )

## [[Text]]
(do-template [<name> <class> <method> <post> <outputT>]
  [(def: (<name> inputI)
     Unary
     (|>> inputI
          ($i.CHECKCAST "java.lang.String")
          ($i.INVOKEVIRTUAL <class> <method> ($t.method (list) (#.Some <outputT>) (list)) #0)
          <post>))]

  [text//size  "java.lang.String" "length"      lux-intI $t.int]
  )

(do-template [<name> <pre-subject> <pre-param> <op> <post>]
  [(def: (<name> [subjectI paramI])
     Binary
     (|>> subjectI <pre-subject>
          paramI <pre-param>
          <op> <post>))]

  [text//eq id id
   ($i.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) #0)
   ($i.wrap #$.Boolean)]
  [text//lt ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String")
   ($i.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) #0)
   (<| (predicateI $i.IF_ICMPEQ) ($i.int -1))]
  [text//concat ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String")
   ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0)
   id]
  [text//char ($i.CHECKCAST "java.lang.String") jvm-intI
   ($i.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) #0)
   id]
  )

(do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>]
  [(def: (<name> [subjectI paramI extraI])
     Trinary
     (|>> subjectI <pre-subject>
          paramI <pre-param>
          extraI <pre-extra>
          <op>))]

  [text//clip ($i.CHECKCAST "java.lang.String") jvm-intI jvm-intI
   ($i.INVOKESTATIC hostL.runtime-class "text_clip"
                    ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) #0)]
  )

(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list)))
(def: (text//index [textI partI startI])
  Trinary
  (<| $i.with-label (function (_ @not-found))
      $i.with-label (function (_ @end))
      (|>> textI ($i.CHECKCAST "java.lang.String")
           partI ($i.CHECKCAST "java.lang.String")
           startI jvm-intI
           ($i.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0)
           $i.DUP
           ($i.int -1)
           ($i.IF_ICMPEQ @not-found)
           lux-intI
           runtimeT.someI
           ($i.GOTO @end)
           ($i.label @not-found)
           $i.POP
           runtimeT.noneI
           ($i.label @end))))

## [[Math]]
(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list)))
(def: math-binary-method ($t.method (list $t.double $t.double) (#.Some $t.double) (list)))

(do-template [<name> <method>]
  [(def: (<name> inputI)
     Unary
     (|>> inputI
          ($i.unwrap #$.Double)
          ($i.INVOKESTATIC "java.lang.Math" <method> math-unary-method #0)
          ($i.wrap #$.Double)))]

  [math//cos "cos"]
  [math//sin "sin"]
  [math//tan "tan"]
  [math//acos "acos"]
  [math//asin "asin"]
  [math//atan "atan"]
  [math//cosh "cosh"]
  [math//sinh "sinh"]
  [math//tanh "tanh"]
  [math//exp "exp"]
  [math//log "log"]
  [math//ceil "ceil"]
  [math//floor "floor"]
  )

(do-template [<name> <method>]
  [(def: (<name> [inputI paramI])
     Binary
     (|>> inputI ($i.unwrap #$.Double)
          paramI ($i.unwrap #$.Double)
          ($i.INVOKESTATIC "java.lang.Math" <method> math-binary-method #0)
          ($i.wrap #$.Double)))]

  [math//atan2 "atan2"]
  [math//pow "pow"]
  )

(def: (math//round inputI)
  Unary
  (|>> inputI
       ($i.unwrap #$.Double)
       ($i.INVOKESTATIC "java.lang.Math" "round" ($t.method (list $t.double) (#.Some $t.long) (list)) #0)
       $i.L2D
       ($i.wrap #$.Double)))

## [[IO]]
(def: string-method $.Method ($t.method (list $String) #.None (list)))
(def: (io//log messageI)
  Unary
  (|>> ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list)))
       messageI
       ($i.CHECKCAST "java.lang.String")
       ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0)
       unitI))

(def: (io//error messageI)
  Unary
  (|>> ($i.NEW "java.lang.Error")
       $i.DUP
       messageI
       ($i.CHECKCAST "java.lang.String")
       ($i.INVOKESPECIAL "java.lang.Error" "<init>" string-method #0)
       $i.ATHROW))

(def: (io//exit codeI)
  Unary
  (|>> codeI jvm-intI
       ($i.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) #0)
       $i.NULL))

(def: (io//current-time [])
  Nullary
  (|>> ($i.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) #0)
       ($i.wrap #$.Long)))

## [[Atoms]]
(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
(def: (atom//new initI)
  Unary
  (|>> ($i.NEW atom-class)
       $i.DUP
       initI
       ($i.INVOKESPECIAL atom-class "<init>" ($t.method (list $Object) #.None (list)) #0)))

(def: (atom//read atomI)
  Unary
  (|>> atomI
       ($i.CHECKCAST atom-class)
       ($i.INVOKEVIRTUAL atom-class "get" ($t.method (list) (#.Some $Object) (list)) #0)))

(def: (atom//compare-and-swap [atomI oldI newI])
  Trinary
  (|>> atomI
       ($i.CHECKCAST atom-class)
       oldI
       newI
       ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) #0)
       ($i.wrap #$.Boolean)))

## [[Box]]
(def: empty-boxI
  $.Inst
  (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object"))))

(def: check-boxI
  $.Inst
  ($i.CHECKCAST ($t.descriptor $Object-Array)))

(def: (box//new initI)
  Unary
  (|>> empty-boxI
       $i.DUP ($i.int 0) initI $i.AASTORE))

(def: (box//read boxI)
  Unary
  (|>> boxI check-boxI
       ($i.int 0) $i.AALOAD))

(def: (box//write [valueI boxI])
  Binary
  (|>> boxI check-boxI
       ($i.int 0) valueI $i.AASTORE
       unitI))

## [[Processes]]
(def: (process//parallelism-level [])
  Nullary
  (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) #0)
       ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) #0)
       lux-intI))

(def: (process//schedule [millisecondsI procedureI])
  Binary
  (|>> millisecondsI ($i.unwrap #$.Long)
       procedureI ($i.CHECKCAST hostL.function-class)
       ($i.INVOKESTATIC hostL.runtime-class "schedule"
                        ($t.method (list $t.long $Function) (#.Some $Object) (list)) #0)))

## [Bundles]
(def: lux-procs
  Bundle
  (|> (dict.new text.Hash<Text>)
      (install "is" (binary lux//is))
      (install "try" (unary lux//try))
      (install "if" (trinary lux//if))
      (install "loop" lux//loop)
      (install "recur" lux//recur)
      ))

(def: bit-procs
  Bundle
  (<| (prefix "bit")
      (|> (dict.new text.Hash<Text>)
          (install "and" (binary bit//and))
          (install "or" (binary bit//or))
          (install "xor" (binary bit//xor))
          (install "left-shift" (binary bit//left-shift))
          (install "logical-right-shift" (binary bit//logical-right-shift))
          (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift))
          )))

(def: int-procs
  Bundle
  (<| (prefix "int")
      (|> (dict.new text.Hash<Text>)
          (install "+" (binary int//add))
          (install "-" (binary int//sub))
          (install "*" (binary int//mul))
          (install "/" (binary int//div))
          (install "%" (binary int//rem))
          (install "=" (binary int//eq))
          (install "<" (binary int//lt))
          (install "to-frac" (unary int//to-frac))
          (install "char" (unary int//char)))))

(def: frac-procs
  Bundle
  (<| (prefix "frac")
      (|> (dict.new text.Hash<Text>)
          (install "+" (binary frac//add))
          (install "-" (binary frac//sub))
          (install "*" (binary frac//mul))
          (install "/" (binary frac//div))
          (install "%" (binary frac//rem))
          (install "=" (binary frac//eq))
          (install "<" (binary frac//lt))
          (install "smallest" (nullary frac//smallest))
          (install "min" (nullary frac//min))
          (install "max" (nullary frac//max))
          (install "to-int" (unary frac//to-int))
          (install "encode" (unary frac//encode))
          (install "decode" (unary frac//decode)))))

(def: text-procs
  Bundle
  (<| (prefix "text")
      (|> (dict.new text.Hash<Text>)
          (install "=" (binary text//eq))
          (install "<" (binary text//lt))
          (install "concat" (binary text//concat))
          (install "index" (trinary text//index))
          (install "size" (unary text//size))
          (install "char" (binary text//char))
          (install "clip" (trinary text//clip))
          )))

(def: array-procs
  Bundle
  (<| (prefix "array")
      (|> (dict.new text.Hash<Text>)
          (install "new" (unary array//new))
          (install "get" (binary array//get))
          (install "put" (trinary array//put))
          (install "remove" (binary array//remove))
          (install "size" (unary array//size))
          )))

(def: math-procs
  Bundle
  (<| (prefix "math")
      (|> (dict.new text.Hash<Text>)
          (install "cos" (unary math//cos))
          (install "sin" (unary math//sin))
          (install "tan" (unary math//tan))
          (install "acos" (unary math//acos))
          (install "asin" (unary math//asin))
          (install "atan" (unary math//atan))
          (install "cosh" (unary math//cosh))
          (install "sinh" (unary math//sinh))
          (install "tanh" (unary math//tanh))
          (install "exp" (unary math//exp))
          (install "log" (unary math//log))
          (install "ceil" (unary math//ceil))
          (install "floor" (unary math//floor))
          (install "round" (unary math//round))
          (install "atan2" (binary math//atan2))
          (install "pow" (binary math//pow))
          )))

(def: io-procs
  Bundle
  (<| (prefix "io")
      (|> (dict.new text.Hash<Text>)
          (install "log" (unary io//log))
          (install "error" (unary io//error))
          (install "exit" (unary io//exit))
          (install "current-time" (nullary io//current-time)))))

(def: atom-procs
  Bundle
  (<| (prefix "atom")
      (|> (dict.new text.Hash<Text>)
          (install "new" (unary atom//new))
          (install "read" (unary atom//read))
          (install "compare-and-swap" (trinary atom//compare-and-swap)))))

(def: box-procs
  Bundle
  (<| (prefix "box")
      (|> (dict.new text.Hash<Text>)
          (install "new" (unary box//new))
          (install "read" (unary box//read))
          (install "write" (binary box//write)))))

(def: process-procs
  Bundle
  (<| (prefix "process")
      (|> (dict.new text.Hash<Text>)
          (install "parallelism-level" (nullary process//parallelism-level))
          (install "schedule" (binary process//schedule))
          )))

(def: #export procedures
  Bundle
  (<| (prefix "lux")
      (|> lux-procs
          (dict.merge bit-procs)
          (dict.merge int-procs)
          (dict.merge frac-procs)
          (dict.merge text-procs)
          (dict.merge array-procs)
          (dict.merge math-procs)
          (dict.merge io-procs)
          (dict.merge atom-procs)
          (dict.merge box-procs)
          (dict.merge process-procs)
          )))