Ported JVM pattern-matching & loop generation to the new JVM bytecode machinery.

7 files changed, 480 insertions, 36 deletions

diff --git a/stdlib/source/lux/target/jvm/instruction.lux b/stdlib/source/lux/target/jvm/instruction.lux
index 10fce7368..59e4b7b44 100644
--- a/stdlib/source/lux/target/jvm/instruction.lux
+++ b/stdlib/source/lux/target/jvm/instruction.lux
@@ -33,7 +33,7 @@
     ["#." constant (#+ UTF8)
      ["#/." pool (#+ Pool)]]
     ["." type (#+ Type)
-     [category (#+ Value' Value Return' Return Method Class)]
+     [category (#+ Class Object Value' Value Return' Return Method)]
      ["." reflection]
      ["." parser]]]])
 
@@ -511,18 +511,18 @@
               (exception.throw ..invalid-lookupswitch []))))
         []]])))
 
-(template [<name> <bytecode>]
+(template [<name> <category> <bytecode>]
   [(def: #export (<name> class)
-     (-> (Type Class) (Instruction Any))
+     (-> (Type <category>) (Instruction Any))
      (do ..monad
        ## TODO: Make sure it"s impossible to have indexes greater than U2.
        [index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
        (..nullary (<bytecode> index))))]
 
-  [new /bytecode.new]
-  [anewarray /bytecode.anewarray]
-  [checkcast /bytecode.checkcast]
-  [instanceof /bytecode.instanceof]
+  [new Class /bytecode.new]
+  [anewarray Object /bytecode.anewarray]
+  [checkcast Object /bytecode.checkcast]
+  [instanceof Object /bytecode.instanceof]
   )
 
 (def: #export (iinc register increase)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
index 97db2b34c..959cc6375 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm.lux
@@ -8,8 +8,8 @@
    ["#." structure]
    ["#." reference]
    ["#." function]
-   ## ["#." case]
-   ## ["#." loop]
+   ["#." case]
+   ["#." loop]
    ["//#" ///
     ## ["." extension]
     [//
@@ -42,20 +42,20 @@
       (#reference.Constant constant)
       (/reference.constant constant))
 
-    ## (^ (synthesis.branch/case case))
-    ## (/case.case generate case)
+    (^ (synthesis.branch/case [valueS pathS]))
+    (/case.case generate valueS pathS)
 
-    ## (^ (synthesis.branch/let let))
-    ## (/case.let generate let)
+    (^ (synthesis.branch/let [inputS register bodyS]))
+    (/case.let generate inputS register bodyS)
 
-    ## (^ (synthesis.branch/if if))
-    ## (/case.if generate if)
+    (^ (synthesis.branch/if [conditionS thenS elseS]))
+    (/case.if generate conditionS thenS elseS)
 
-    ## (^ (synthesis.loop/scope scope))
-    ## (/loop.scope generate scope)
+    (^ (synthesis.loop/scope scope))
+    (/loop.scope generate scope)
 
-    ## (^ (synthesis.loop/recur updates))
-    ## (/loop.recur generate updates)
+    (^ (synthesis.loop/recur updates))
+    (/loop.recur generate updates)
 
     (^ (synthesis.function/abstraction abstraction))
     (/function.abstraction generate abstraction)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
new file mode 100644
index 000000000..1fe43b8da
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/case.lux
@@ -0,0 +1,275 @@
+(.module:
+  [lux (#- Type if let case)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." function]]
+   [data
+    [number
+     ["." i32]
+     ["n" nat]]]
+   [target
+    [jvm
+     ["." constant]
+     ["_" instruction (#+ Label Instruction) ("#@." monad)]
+     ["." type (#+ Type)
+      [category (#+ Method)]]
+     [encoding
+      ["." unsigned]]]]]
+  ["." // #_
+   ["#." runtime (#+ Operation Phase)]
+   ["#." value]
+   [////
+    [reference (#+ Register)]
+    ["." synthesis (#+ Path Synthesis)]
+    ["." phase ("operation@." monad)
+     ["." generation]]]])
+
+(def: $Object (type.class "java.lang.Object" (list)))
+
+(def: equals-name
+  "equals")
+
+(def: equals-type
+  (type.method [(list //value.type) type.boolean (list)]))
+
+(def: (pop-alt stack-depth)
+  (-> Nat (Instruction Any))
+  (.case stack-depth
+    0 (_@wrap [])
+    1 _.pop
+    2 _.pop2
+    _ ## (n.> 2)
+    ($_ _.compose
+        _.pop2
+        (pop-alt (n.- 2 stack-depth)))))
+
+(def: ldc/integer
+  (-> (I64 Any) (Instruction Any))
+  (|>> .i64 i32.i32 constant.integer _.ldc/integer))
+
+(def: ldc/long
+  (-> (I64 Any) (Instruction Any))
+  (|>> .int constant.long _.ldc/long))
+
+(def: ldc/double
+  (-> Frac (Instruction Any))
+  (|>> constant.double _.ldc/double))
+
+(def: peek
+  (Instruction Any)
+  ($_ _.compose
+      _.dup
+      (..ldc/integer 0)
+      _.aaload))
+
+(def: pop
+  (Instruction Any)
+  ($_ _.compose
+      (..ldc/integer 1)
+      _.aaload
+      (_.checkcast //runtime.$Stack)))
+
+(def: left-flag _.aconst-null)
+(def: right-flag (_.ldc/string ""))
+
+(def: (path' phase stack-depth @else @end path)
+  (-> Phase Nat Label Label Path (Operation (Instruction Any)))
+  (.case path
+    #synthesis.Pop
+    (operation@wrap ..pop)
+    
+    (#synthesis.Bind register)
+    (operation@wrap ($_ _.compose
+                        ..peek
+                        (_.astore (unsigned.u1 register))))
+
+    (^ (synthesis.path/bit value))
+    (operation@wrap (.let [jump (.if value _.ifeq _.ifne)]
+                      ($_ _.compose
+                          ..peek
+                          (//value.unwrap type.boolean)
+                          (jump @else))))
+    
+    (^ (synthesis.path/i64 value))
+    (operation@wrap ($_ _.compose
+                        ..peek
+                        (//value.unwrap type.long)
+                        (..ldc/long value)
+                        _.lcmp
+                        (_.ifne @else)))
+    
+    (^ (synthesis.path/f64 value))
+    (operation@wrap ($_ _.compose
+                        ..peek
+                        (//value.unwrap type.double)
+                        (..ldc/double value)
+                        _.dcmpl
+                        (_.ifne @else)))
+    
+    (^ (synthesis.path/text value))
+    (operation@wrap ($_ _.compose
+                        ..peek
+                        (_.ldc/string value)
+                        (_.invokevirtual ..$Object ..equals-name ..equals-type)
+                        (_.ifeq @else)))
+    
+    (#synthesis.Then bodyS)
+    (do phase.monad
+      [bodyG (phase bodyS)]
+      (wrap ($_ _.compose
+                (..pop-alt stack-depth)
+                bodyG
+                (_.goto @end))))
+    
+    (^template [<pattern> <flag> <prepare>]
+      (^ (<pattern> idx))
+      (operation@wrap
+       (do _.monad
+         [@success _.new-label
+          @fail _.new-label]
+         ($_ _.compose
+             ..peek
+             (_.checkcast //runtime.$Variant)
+             (..ldc/integer (<prepare> idx))
+             <flag>
+             //runtime.case
+             _.dup
+             (_.ifnull @fail)
+             (_.goto @success)
+             (_.set-label @fail)
+             _.pop
+             (_.goto @else)
+             (_.set-label @success)
+             //runtime.push))))
+    ([synthesis.side/left  ..left-flag function.identity]
+     [synthesis.side/right ..right-flag .inc])
+
+    (^ (synthesis.member/left lefts))
+    (operation@wrap (.let [optimized-projection (.case lefts
+                                                  0
+                                                  _.aaload
+                                                  
+                                                  lefts
+                                                  //runtime.left)]
+                      ($_ _.compose
+                          ..peek
+                          (_.checkcast //runtime.$Tuple)
+                          (..ldc/integer lefts)
+                          optimized-projection
+                          //runtime.push)))
+
+    (^ (synthesis.member/right lefts))
+    (operation@wrap ($_ _.compose
+                        ..peek
+                        (_.checkcast //runtime.$Tuple)
+                        (..ldc/integer lefts)
+                        //runtime.right
+                        //runtime.push))
+    
+    ## Extra optimization
+    (^ (synthesis.path/seq
+        (synthesis.member/left 0)
+        (synthesis.!bind-top register thenP)))
+    (do phase.monad
+      [thenG (path' phase stack-depth @else @end thenP)]
+      (wrap ($_ _.compose
+                ..peek
+                (_.checkcast //runtime.$Tuple)
+                (..ldc/integer 0)
+                _.aaload
+                (_.astore (unsigned.u1 register))
+                thenG)))
+
+    ## Extra optimization
+    (^template [<pm> <projection>]
+      (^ (synthesis.path/seq
+          (<pm> lefts)
+          (synthesis.!bind-top register thenP)))
+      (do phase.monad
+        [then! (path' phase stack-depth @else @end thenP)]
+        (wrap ($_ _.compose
+                  ..peek
+                  (_.checkcast //runtime.$Tuple)
+                  (..ldc/integer lefts)
+                  <projection>
+                  (_.astore (unsigned.u1 register))
+                  then!))))
+    ([synthesis.member/left  //runtime.left]
+     [synthesis.member/right //runtime.right])
+
+    (#synthesis.Alt leftP rightP)
+    (do phase.monad
+      [@alt-else generation.next
+       left! (path' phase (inc stack-depth) @alt-else @end leftP)
+       right! (path' phase stack-depth @else @end rightP)]
+      (wrap ($_ _.compose
+                _.dup
+                left!
+                (_.set-label @alt-else)
+                _.pop
+                right!)))
+    
+    (#synthesis.Seq leftP rightP)
+    (do phase.monad
+      [left! (path' phase stack-depth @else @end leftP)
+       right! (path' phase stack-depth @else @end rightP)]
+      (wrap ($_ _.compose
+                left!
+                right!)))
+    ))
+
+(def: (path phase path @end)
+  (-> Phase Path Label (Operation (Instruction Any)))
+  (do phase.monad
+    [@else generation.next
+     pathG (..path' phase 1 @else @end path)]
+    (wrap ($_ _.compose
+              pathG
+              (_.set-label @else)
+              _.pop
+              //runtime.pm-failure
+              _.aconst-null
+              (_.goto @end)))))
+
+(def: #export (if phase conditionS thenS elseS)
+  (-> Phase Synthesis Synthesis Synthesis (Operation (Instruction Any)))
+  (do phase.monad
+    [conditionG (phase conditionS)
+     thenG (phase thenS)
+     elseG (phase elseS)]
+    (wrap (do _.monad
+            [@else _.new-label
+             @end _.new-label]
+            ($_ _.compose
+                conditionG
+                (//value.unwrap type.boolean)
+                (_.ifeq @else)
+                thenG
+                (_.goto @end)
+                (_.set-label @else)
+                elseG
+                (_.set-label @end))))))
+
+(def: #export (let phase inputS register bodyS)
+  (-> Phase Synthesis Register Synthesis (Operation (Instruction Any)))
+  (do phase.monad
+    [inputG (phase inputS)
+     bodyG (phase bodyS)]
+    (wrap ($_ _.compose
+              inputG
+              (_.astore (unsigned.u1 register))
+              bodyG))))
+
+(def: #export (case phase valueS path)
+  (-> Phase Synthesis Path (Operation (Instruction Any)))
+  (do phase.monad
+    [@end generation.next
+     valueG (phase valueS)
+     pathG (..path phase path @end)]
+    (wrap ($_ _.compose
+              _.aconst-null
+              valueG
+              //runtime.push
+              pathG
+              (_.set-label @end)))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux
new file mode 100644
index 000000000..5537715b0
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/loop.lux
@@ -0,0 +1,89 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." function]]
+   [data
+    ["." product]
+    [number
+     ["n" nat]]
+    [collection
+     ["." list ("#@." functor)]]]
+   [target
+    [jvm
+     ["_" instruction (#+ Label Instruction) ("#@." monad)]
+     [encoding
+      ["." unsigned]]]]]
+  ["." // #_
+   ["#." runtime (#+ Operation Phase)]
+   ["#." value]
+   [////
+    [reference (#+ Register)]
+    ["." synthesis (#+ Path Synthesis)]
+    ["." phase
+     ["." generation]]]])
+
+(def: (invariant? register changeS)
+  (-> Register Synthesis Bit)
+  (case changeS
+    (^ (synthesis.variable/local var))
+    (n.= register var)
+
+    _
+    false))
+
+(def: no-op
+  (_@wrap []))
+
+(def: #export (recur translate updatesS)
+  (-> Phase (List Synthesis) (Operation (Instruction Any)))
+  (do phase.monad
+    [[@begin offset] generation.anchor
+     updatesG (|> updatesS
+                  list.enumerate
+                  (list@map (function (_ [index updateS])
+                              [(n.+ offset index) updateS]))
+                  (monad.map @ (function (_ [register updateS])
+                                 (if (invariant? register updateS)
+                                   (wrap [..no-op
+                                          ..no-op])
+                                   (do @
+                                     [fetchG (translate updateS)
+                                      #let [storeG (_.astore (unsigned.u1 register))]]
+                                     (wrap [fetchG storeG]))))))]
+    (wrap ($_ _.compose
+              ## It may look weird that first I fetch all the values separately,
+              ## and then I store them all.
+              ## It must be done that way in order to avoid a potential bug.
+              ## Let's say that you'll recur with 2 expressions: X and Y.
+              ## If Y depends on the value of X, and you don't perform fetches
+              ## and stores separately, then by the time Y is evaluated, it
+              ## will refer to the new value of X, instead of the old value, as
+              ## should be the case.
+              (|> updatesG
+                  (list@map product.left)
+                  (monad.seq _.monad))
+              (|> updatesG
+                  list.reverse
+                  (list@map product.right)
+                  (monad.seq _.monad))
+              (_.goto @begin)))))
+
+(def: #export (scope translate [offset initsS+ iterationS])
+  (-> Phase [Nat (List Synthesis) Synthesis] (Operation (Instruction Any)))
+  (do phase.monad
+    [@begin generation.next
+     initsI+ (monad.map @ translate initsS+)
+     iterationG (generation.with-anchor [@begin offset]
+                  (translate iterationS))
+     #let [initializationG (|> (list.enumerate initsI+)
+                               (list@map (function (_ [index initG])
+                                           ($_ _.compose
+                                               initG
+                                               (_.astore (unsigned.u1 (n.+ offset index))))))
+                               (monad.seq _.monad))]]
+    (wrap ($_ _.compose
+              initializationG
+              (_.set-label @begin)
+              iterationG))))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
index 05ef66973..078a136b7 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/runtime.lux
@@ -1,17 +1,17 @@
 (.module:
-  [lux (#- Definition)
+  [lux (#- Type Definition case)
    [data
     [binary (#+ Binary)]]
    [target
     [jvm
      ["_" instruction (#+ Label Instruction)]
-     [encoding
-      [name (#+ External)]]
-     ["." type
-      [category (#+ Value Return Method)]]]]]
-  ["." ///
-   [///
-    [reference (#+ Register)]]]
+     ["." type (#+ Type)
+      ["." category (#+ Method)]]]]]
+  ["." // #_
+   ["#." value]
+   ["/#" //
+    [///
+     [reference (#+ Register)]]]]
   )
 
 (type: #export Byte-Code Binary)
@@ -35,12 +35,51 @@
 
 (def: #export class (type.class "LuxRuntime" (list)))
 
-(def: apply-failure-name
-  "apply_fail")
+(def: #export $Tag type.int)
+(def: #export $Flag //value.type)
+(def: #export $Variant (type.array //value.type))
 
-(def: apply-failure-type
+(def: #export $Offset type.int)
+(def: #export $Tuple (type.array //value.type))
+
+(def: #export $Stack (type.array //value.type))
+
+(def: procedure
+  (-> Text (Type Method) (Instruction Any))
+  (_.invokestatic ..class))
+
+(def: failure-type
   (type.method [(list) type.void (list)]))
 
 (def: #export apply-failure
-  (Instruction Any)
-  (_.invokestatic ..class ..apply-failure-name ..apply-failure-type))
+  (..procedure "apply_failure" ..failure-type))
+
+(def: #export pm-failure
+  (..procedure "pm_failure" ..failure-type))
+
+(def: push-name
+  "push")
+
+(def: push-type
+  (type.method [(list ..$Stack //value.type) ..$Stack (list)]))
+
+(def: #export push
+  (..procedure ..push-name ..push-type))
+
+(def: case-name
+  "case")
+
+(def: case-type
+  (type.method [(list ..$Variant ..$Tag ..$Flag) //value.type (list)]))
+
+(def: #export case
+  (..procedure ..case-name ..case-type))
+
+(def: projection-type
+  (type.method [(list ..$Tuple $Offset) //value.type (list)]))
+
+(def: #export left
+  (..procedure "left" ..projection-type))
+
+(def: #export right
+  (..procedure "right" ..projection-type))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
index 52fcc390a..803ac2522 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/value.lux
@@ -1,9 +1,50 @@
 (.module:
-  [lux (#- type)
+  [lux (#- Type type)
    [target
     [jvm
-     ["." type]]]])
+     ["_" instruction (#+ Instruction)]
+     ["." type (#+ Type) ("#@." equivalence)
+      [category (#+ Primitive)]
+      ["." box]]]]])
 
 (def: #export field "value")
 
 (def: #export type (type.class "java.lang.Object" (list)))
+
+(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
+  [(def: (<name> type)
+     (-> (Type Primitive) Text)
+     (`` (cond (~~ (template [<type> <output>]
+                     [(type@= <type> type) <output>]
+                     
+                     [type.boolean <boolean>]
+                     [type.byte    <byte>]
+                     [type.short   <short>]
+                     [type.int     <int>]
+                     [type.long    <long>]
+                     [type.float   <float>]
+                     [type.double  <double>]
+                     [type.char    <char>]))
+               ## else
+               (undefined))))]
+
+  [primitive-wrapper
+   box.boolean box.byte box.short box.int
+   box.long box.float box.double box.char]
+  [primitive-unwrap
+   "booleanValue" "byteValue" "shortValue" "intValue"
+   "longValue" "floatValue" "doubleValue" "charValue"]
+  )
+
+(def: #export (wrap type)
+  (-> (Type Primitive) (Instruction Any))
+  (let [wrapper (type.class (primitive-wrapper type) (list))]
+    (_.invokestatic wrapper "valueOf"
+                    (type.method [(list type) wrapper (list)]))))
+
+(def: #export (unwrap type)
+  (-> (Type Primitive) (Instruction Any))
+  (let [wrapper (type.class (primitive-wrapper type) (list))]
+    ($_ _.compose
+        (_.checkcast wrapper)
+        (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)])))))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 85b062009..0efa89571 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -2,8 +2,8 @@
                                           [primitive (#+)]
                                           [structure (#+)]
                                           [reference (#+)]
-                                          ## [case (#+)]
-                                          ## [loop (#+)]
+                                          [case (#+)]
+                                          [loop (#+)]
                                           [function (#+)]
                                           ## [extension (#+)]
                                           )]