VM Backend

koka.cabal

@@ -30,6 +30,7 @@ library
       Backend.C.ParcReuseSpec
       Backend.CSharp.FromCore
       Backend.JavaScript.FromCore
+      Backend.VM.FromCore
       Common.ColorScheme
       Common.Error
       Common.Failure

lib/std/core.kk

@@ -221,12 +221,12 @@ pub extern main-console : forall<a,e> ( main : () -> e a ) -> e a
   js inline "(#1)()"
 
 
-// Return the host environment: `dotnet`, `browser`, `webworker`, `node`, or `libc`.
+// Return the host environment: `dotnet`, `browser`, `webworker`, `node`, or `libc`, or `vm`.
 pub extern host() : ndet string
   c "kk_get_host"
   cs inline "\"dotnet\""
   js inline "$std_core_console._host"
-
+  vm "!sexp:\"vm\""
 
 // The default exception handler
 pub fun @default-exn(action : () -> <exn,console|e> () ) : <console|e> ()

lib/std/core/console.kk

@@ -39,12 +39,14 @@ extern xprintsln(s : string) : console ()
   c  "kk_println"
   cs "Console.WriteLine"
   js "_println"
+  vm "println(String): Unit"
 
 // Print a string to the console
 extern xprints( s : string) : console ()
   c  "kk_print"
   cs "Console.Write"
   js "_print"
+  vm "!sexp:(\"write(OutStream, String): Unit\" (\"getStdout(): OutStream\") $arg0:str)"
 
 // _Unsafe_. This function removes the state effect from the effect of an action
 inline extern unsafe-nostate( action : () -> <st<h>,console> a ) : (() -> console a)

lib/std/core/hnd.kk

@@ -109,6 +109,7 @@ import std/core/undiv
 extern import
   c  file "inline/hnd"
   js file "inline/hnd.js"
+  vm file "inline/hnd.mcore.sexp"
 
 // -------------------------------------------
 // Internal types
@@ -157,11 +158,12 @@ extern eq-marker( x : marker<e1,a1>, y : marker<e2,a2> ) : bool
 extern fresh-marker() : marker<e,a>
   c inline "kk_marker_unique(kk_context())"
   js inline "$marker_unique++"
+  vm "!sexp:(fresh-label)"
 
 extern fresh-marker-named() : marker<e,a>
   c inline  "-kk_marker_unique(kk_context())"
   js inline "-($marker_unique++)"
-
+  vm "!sexp:(fresh-label)"
 
 
 // -------------------------------------------
@@ -175,6 +177,7 @@ extern fresh-marker-named() : marker<e,a>
 extern evv-insert( evv : evv<e1>, ev : ev<h> ) : e1 evv<e2>
   c  "kk_evv_insert"
   js "_evv_insert"
+  vm "!sexp:($evvInsert:(fun Pure (ptr ptr) ptr) $arg0:ptr $arg1:ptr)"
 
 // show evidence for debug purposes
 extern evv-show( evv : evv<e> ) : string
@@ -186,6 +189,7 @@ extern evv-show( evv : evv<e> ) : string
 extern evv-eq(evv0 : evv<e>, evv1 : evv<e> ) : bool
   c  "kk_evv_eq"
   js inline "(#1) === (#2)"
+  vm "ptr_eq"
 
 
 // -------------------------------------------
@@ -196,22 +200,26 @@ extern evv-eq(evv0 : evv<e>, evv1 : evv<e> ) : bool
 pub inline extern @evv-at<e,h> ( i : ev-index ) : ev<h>  // pretend total; don't simplify
   c  "kk_evv_at"
   js "$std_core_hnd._evv_at"
+  vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"elt\" (fun Pure (ptr int) ptr)) (\"promote_ptr\" ((qualified $\"import$std/core/hnd\":ptr \"getCurrentEvv\" (fun Effectful () ptr)))) $arg0:int)"
 
 // (dynamically) find evidence insertion/deletion index in the evidence vector
 // The compiler optimizes `@evv-index` to a static index when apparent from the effect type.
 pub extern @evv-index<e::E,h>( htag : htag<h> ) : e ev-index
   c  "kk_evv_index"
   js "__evv_index"
+  vm "!sexp:($evvIndex:(fun Pure (ptr ptr int) int) ($getCurrentEvv:(fun Effectful (ptr) ptr)) $arg0:ptr 0)"
 
 // Get the current evidence vector.
 extern evv-get() : e evv<e>
   c  "kk_evv_get"
   js "$std_core_hnd._evv_get"
+  vm "!sexp:($getCurrentEvv:(fun Effectful () ptr))"
 
 // Set the current evidence vector.
 inline extern evv-set<e1,e>( w : evv<e1> ) : e ()
   c  "kk_evv_set"
   js "$std_core_hnd._evv_set"
+  vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"setCurrentEvv\" (fun Effectful (ptr) unit)) $arg0:ptr)"
 
 // Does the current evidence vector consist solely of affine handlers?
 // This is called in backends that do not have context paths (like javascript)
@@ -230,6 +238,7 @@ inline extern evv-set<e1,e>( w : evv<e1> ) : e ()
 pub extern @evv-is-affine() : bool
   c  inline "kk_evv_is_affine(kk_context())"
   js inline "$std_core_hnd._evv_is_affine_()"
+  vm "!sexp:0"
 
 
 // -----------------------------------------------------------------------------------
@@ -241,24 +250,28 @@ pub extern @evv-is-affine() : bool
 inline extern evv-swap<e1,e2>( w : evv<e1> ) : e evv<e2>
   c  "kk_evv_swap"
   js "$std_core_hnd._evv_swap"
+  vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"swapCurrentEvv\" (fun Effectful (ptr) ptr)) $arg0:ptr)"
 
 // Remove evidence at index `i` of the current evidence vector, and return the old one.
 // (used by `mask`)
 extern evv-swap-delete( i : ev-index, behind : bool ) : e1 evv<e>
   c  "kk_evv_swap_delete"
   js "_evv_swap_delete"
+  vm "!sexp:($evvSwapDelete:(fun Effectful (int int) ptr) $arg0:int $arg1:int)"
 
 // Swap the current evidence vector with an empty vector.
 // (this is used in open calls to switch to a total context)
 inline extern evv-swap-create0() : e evv<e>  //not quite the right effect type but avoids unbound effect types
   c  "kk_evv_swap_create0"
   js "$std_core_hnd._evv_swap_create0"
+  vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"evvSwapCreate0\" (fun Effectful () ptr)))"
 
 // Swap the current evidence vector with a singleton vector (with the evidence at current index `i`).
 // (this is common in open calls to switch to a singleton effect context when calling operations)
 inline extern evv-swap-create1( i : ev-index ) : e evv<e>  //not quite the right effect type but avoids unbound effect types
   c  "kk_evv_swap_create1"
   js "$std_core_hnd._evv_swap_create1"
+  vm "!sexp:((qualified $\"import$std/core/hnd\":ptr \"evvSwapCreate1\" (fun Effectful (int) ptr)) $arg0:ptr)"
 
 // Swap the current evidence vector with a new vector consisting of evidence
 // at indices `indices` in the current vector.
@@ -275,10 +288,12 @@ extern evv-swap-create( indices : vector<ev-index> ) : e evv<e>  //not quite the
 pub inline extern yielding() : bool
   c  "kk_yielding"
   js "$std_core_hnd._yielding"
+  vm "!sexp:0"
 
 pub inline extern yielding-non-final() : bool
   c  "kk_yielding_non_final"
   js "$std_core_hnd._yielding_non_final"
+  vm "!sexp:0"
 
 pub noinline extern yield-extend(next : a -> e b ) : e b
   c  "kk_yield_extend"
@@ -301,11 +316,17 @@ inline extern keep-yielding-final() : e r
 extern yield-prompt( m: marker<e,r> ) : yld<e,a,r>
   c  "kk_yield_prompt"
   js "_yield_prompt"
+  vm "!sexp:(reset ($arg0:ptr $ignore:ptr) $std/core/hnd/Pure:ptr (($ret:ptr) $ret:ptr))"
 
-extern yield-to-prim( m : marker<e1,r>, clause : (resume-result<b,r> -> e1 r) -> e1 r ) : e (() -> b)
+noinline extern yield-to-prim( m : marker<e1,r>, clause : (resume-result<b,r> -> e1 r) -> e1 r ) : e (() -> b)
   c  "kk_yield_to"
   js "$std_core_hnd._yield_to"
 
+extern @yield-to-prim-vm( m : marker<e1,r>, clause : (b -> e1 r) -> e1 r ) : e b
+  vm "!sexp:(debugWrap \"yield-to-prim\" (shift:top ($arg0:ptr 0) ($resume:top) ($arg1:ptr (lambda ($val:top) (debugWrap \"Resuming\" (resume $resume:ptr $val:top) ) )))) )"
+  c inline "kk_box_null()"
+  js inline "undefined"
+
 extern yield-to-final( m : marker<e1,r>, clause : (resume-result<b,r> -> e1 r) -> e1 r ) : e b
   c  "kk_yield_final"
   js "$std_core_hnd._yield_final"
@@ -317,6 +338,12 @@ noinline fun yield-to( m : marker<e1,r>, clause : (resume-result<b,r> -> e1 r) -
     // val keep1 = guard(w0)  // check the evidence is correctly restored
     f()
 
+noinline fun @yield-to-vm( m : marker<e1,r>, clause : (b -> e1 r) -> e1 r ) : e1 b
+  val w0 = evv-get()
+  val r = @yield-to-prim-vm(m, clause)
+  evv-set(w0)
+  r
+
 pub type yield-info
 
 extern yield-capture() : e yield-info
@@ -415,6 +442,22 @@ pub noinline fun @hhandle( tag:htag<h>, h : h<e,r>, ret: a -> e r, action : () -
   // call action first (this may be yielding), then check the result
   prompt(w0,w1,ev,m,ret,cast-ev0(action)())
 
+extern @reset-vm( m : marker<e0,r>, ret : a -> e0 r, action : () -> e0 a) : e0 r
+  c inline "kk_box_null()"
+  js inline "undefined"
+  vm "!sexp:(debugWrap \"reset\" (reset ($arg0:ptr $ignore:ptr) (the top ($arg2:ptr)) (($res:top) (debugWrap \"returnClause\" ($arg1:ptr $res:top) ) ) ) )"
+
+pub noinline fun @hhandle-vm( tag:htag<h>, h : h<e,r>, ret: a -> e r, action : () -> e1 a ) : e r
+  // insert new evidence for our handler
+  val w0 = evv-get()
+  val m  = fresh-marker()
+  val ev = Ev(tag,m,h,w0)
+  val w1 = evv-insert(w0,ev)
+  evv-set(w1)
+  val res = @reset-vm(m,ret,cast-ev0(action))
+  evv-set(w0)
+  res
+
 // -------------------------------------------
 // named handler
 // (which is not inserted into the evidence vector)
@@ -426,6 +469,7 @@ pub noinline fun @named-handle( tag:htag<h>, h : h<e,r>, ret: a -> e r, action :
   val ev = Ev(tag,m,h,w0)
   prompt(w0,w0,ev,m,ret,cast-ev1(action)(ev))
 
+// TODO define @named-handle-vm to make this work
 
 // -------------------------------------------
 // mask
@@ -465,6 +509,14 @@ pub inline fun local-var(init:a, action: (l:local-var<s,a>) -> <local<s>|e> b )
     val res = cast-ev1(action)(std/core/types/@byref(loc))
     prompt-local-var(std/core/types/@byref(loc),res)
 
+extern @prompt-local-var-prim-vm(init: a, action: (l:local-var<s,a>) -> <local<s>|e> b): <local<s>|e> b
+  vm "!sexp:(debugWrap \"prompt-local-var-prim\" (reset ((fresh-label) $reg:ptr) (the top (letref ($ref:ptr $reg:ptr $arg0:top) ($arg1:top $ref:ptr))) (($res:top) $res:top)))"
+  c inline "kk_box_null()"
+  js inline "undefined"
+
+pub fun local-var-vm(init:a, action: (l:local-var<s,a>) -> <local<s>|e> b ) : <local<s>|e> b
+  @prompt-local-var-prim-vm(init, action)
+
 
 // -------------------------------------------
 // Finally
@@ -501,12 +553,14 @@ inline extern add(i : int, j : int) : int
   c  "kk_integer_add"
   cs inline "(#1 + #2)"
   js inline "(#1 + #2)" // "$std_core_types._int_add"
+  vm "infixAdd(Int, Int): Int"
 
 // are two integers equal?
 inline extern eq( ^x : int, ^y : int) : bool
   c  "kk_integer_eq_borrow"
   cs inline "(#1 == #2)"
   js inline "(#1 == #2)" // $std_core_types._int_eq"
+  vm "infixEq(Int, Int): Int"
 
 
 pub fun initially(init : (int) -> e (), action : () -> e a ) : e a
@@ -555,6 +609,7 @@ abstract value type clause1<a::V,b::V,h::(E,V)->V,e::E,r::V>
 
 inline extern cast-clause0( f : (marker<e1,r>,ev<h>) -> e1 b) : e ((marker<e1,r>,ev<h>) -> e b)
   inline "#1"
+  vm "!sexp:(debugWrap \"cast-clause0\" $arg0:top)"
 
 inline extern cast-clause1( f : (marker<e1,r>,ev<h>,a) -> e1 b) : e ((marker<e1,r>,ev<h>,a) -> e b)
   inline "#1"
@@ -604,7 +659,7 @@ fun protect-check( resumed : ref<global,bool>,  k : resume-result<b,r> -> e r, r
    then k(Finalize(res)) //finalize(k,res)
    else res
 
-fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result<b,r> -> e r ) : e r
+noinline fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result<b,r> -> e r ) : e r
   val resumed = (unsafe-st{ref(False)})()
   fun kprotect(ret)
     (unsafe-st{resumed := True})()
@@ -613,6 +668,9 @@ fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result<b,r> -
   if yielding() return yield-extend( fn(xres) protect-check(resumed,k,xres) )
   protect-check(resumed,k,res)
 
+noinline fun @protect-vm( x : a, clause : (x:a, k: b -> e r) -> e r, k : b -> e r) : e r
+  clause(x, k)
+
 /*
 pub fun clause-control1( clause : (x:a, k: b -> e r) -> e r ) : clause1<a,b,e,r>
   Clause1(fn(m,w,x){ yield-to(m, fn(k){ clause(x, fn(r){ k({r}) } ) }) })

lib/std/core/inline/hnd.mcore.sexp

@@ -0,0 +1,88 @@
+(define $"import$std/core/hnd":ptr (this-lib))
+
+;; Current evidence vector
+;; -----------------------
+(define $getCurrentEvv:(fun Effectful () ptr) (lambda ()
+  ("getRef(Ref[Ptr]): Ptr" ("getGlobal(String): Ptr" "current-evv")))
+  :export-as ("getCurrentEvv"))
+(define $setCurrentEvv:(fun Effectful (ptr) unit) (lambda ($evv:ptr)
+  ("setRef(Ref[Ptr], Ptr): Unit" ("getGlobal(String): Ptr" "current-evv") $evv:ptr))
+  :export-as ("setCurrentEvv"))
+(define $swapCurrentEvv:(fun Effectful (ptr) ptr) (lambda ($evv:ptr)
+  (letrec ((define $ref:ptr ("getGlobal(String): Ptr" "current-evv"))
+           (define $old:ptr ("getRef(Ref[Ptr]): Ptr" $ref:ptr)))
+    (begin
+      ("setRef(Ref[Ptr], Ptr): Unit" $ref:ptr $evv:ptr)
+      $old:ptr)))
+  :export-as ("swapCurrentEvv"))
+(define $evvSwapCreate1:(fun Effectful (int) ptr) (lambda ($n:int)
+  (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr)))
+           (define $ev:ptr ($elt:top $cur:ptr $n:int))
+           (define $next:ptr (make $evv $cons ($ev:ptr (make $evv $nil ())))))
+    (begin
+      ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr)
+      $cur:ptr)))
+  :export-as ("evvSwapCreate1"))
+(define $evvSwapCreate0:(fun Effectful () ptr) (lambda ()
+  (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr)))
+           (define $next:ptr (make $evv $nil ())))
+    (begin
+      ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr)
+      $cur:ptr)))
+  :export-as ("evvSwapCreate0"))
+(define $evvSwapDelete:(fun Effectful (int int) ptr) (lambda ($i:int $behind:int)
+  (letrec ((define $cur:ptr ($getCurrentEvv:(fun Effectful () ptr)))
+           (define $next:ptr ($evvDelete:(fun Pure (int ptr) ptr) ("infixAdd(Int, Int): Int" $i:int $behind:int) $cur:ptr)))
+    (begin
+      ($setCurrentEvv:(fun Effectful (ptr) unit) $next:ptr)
+      $cur:ptr)))
+  :export-as ("evvSwapDelete"))
+(define $evHtag:(fun Pure (ptr) str) (lambda ($ev:ptr)
+  (project (project $ev:ptr $std/core/hnd/ev $std/core/hnd/Ev 0)
+    $std/core/hnd/htag $std/core/hnd/Htag 0)))
+
+;; make primitive?
+(define $evvDelete:(fun Pure (int int ptr) ptr) (lambda ($i:int $evv:ptr)
+  (match ($evv:ptr $evv)
+    ($cons ($hd:ptr $tl:ptr)
+      (switch $i:int
+        (0 $tl:ptr)
+        (_ (make $evv $cons (
+              $hd:ptr
+              ($evvDelete:(fun Pure (int int ptr) ptr) ("infixSub(Int, Int): Int" $i:int 1) $tl:ptr))))))
+    (_ () ("panic(String): Bottom" "Out of bounds index into evidence vector"))))
+  :export-as ("evvDelete"))
+(define $evvInsert:(fun Pure (ptr ptr) ptr) (lambda ($evv:ptr $ev:ptr)
+  (match ($evv:ptr $evv) 
+     ($cons ($fst:ptr $rst:ptr)
+        (switch ("infixGt(String, String): Boolean" 
+                   ($evHtag:(fun Pure (ptr) str) $ev:ptr)
+                   ($evHtag:(fun Pure (ptr) str) $fst:ptr))
+          (1 (make $evv $cons (
+                $fst:ptr
+                ($evvInsert:(fun Pure (ptr ptr) ptr) $rst:ptr $ev:ptr))))
+          (_ (make $evv $cons ($ev:ptr $evv:ptr)))))
+     (_ () (make $evv $cons ($ev:ptr $evv:ptr)))))
+  :export-as ("evvInsert"))
+(define $evvIndex:(fun Pure (ptr ptr int) int) (lambda ($evv:ptr $htag:ptr $acc:int) ;; Find by htag
+  (match ($evv:ptr $evv)
+    ($cons ($fst:ptr $rst:ptr)
+      (switch ("infixEq(String, String): Boolean"
+                 (project $htag:ptr $std/core/hnd/htag $std/core/hnd/Htag 0)
+                 ($evHtag:(fun Pure (ptr) str) $fst:ptr))
+        (1 $acc:int)
+        (_ ($evvIndex:(fun Pure (ptr ptr int) int) $rst:ptr $htag:ptr 
+             ("infixAdd(Int, Int): Int" $acc:int 1)))))
+    (_ () ("!undefined:no evidence for htag"))))
+  :export-as ("evvIndex"))
+
+;; List utilities
+;; --------------
+(define $elt:top (lambda ($l:ptr $n:int) 
+  (switch $n:int 
+    (0 (project $l:ptr $evv $cons 0)) 
+    (_ ($elt:top (project $l:ptr $evv $cons 1) 
+                 ("infixSub(Int, Int): Int" $n:int 1)))))
+  :export-as ("elt"))
+
+(unit)

lib/std/core/inline/int.mcore.sexp

@@ -0,0 +1,17 @@
+;; Converting from strings
+(define $parseWithBase:(fun Pure (str int) ptr) (lambda ($s:str $base:int)
+  (prim ($res:int $err:int) ("read(String, Int): Int" $s:str $base:int)
+    (switch $err:int
+      (1 ;; OK
+         (make $std/core/types/maybe $std/core/types/Just ($res:top)))
+      (_ ;; couldnt parse
+         (make $std/core/types/maybe $std/core/types/Nothing ()))))))
+(define $xparseImpl:(fun Pure (str int) ptr) (lambda ($s:str $hex:int)
+  (switch $hex:int
+    (0 ;; parse
+       ($parseWithBase:(fun Pure (str int) ptr) $s:str 0)
+    )
+    (_ ;; hexadecimal
+       ($parseWithBase:(fun Pure (str int) ptr) $s:str 16)))))
+
+(unit)

lib/std/core/inline/vector.mcore.sexp

@@ -0,0 +1,11 @@
+;; File with definitions for vectors (incomplete)
+(define $vectorToList:top (lambda ($vec:ptr $tail:ptr $i:int)
+  (switch $i:int
+    (0 $tail:ptr)
+    (_ (letrec ((define $ni:int ("infixSub(Int, Int): Int" $i:int 1))
+                (define $el:ptr ("unsafeIndex(Array[Ptr], Int): Ptr" $vec:ptr $ni:int))
+                (define $ntl:ptr (make $std/core/types/list $std/core/types/Cons 
+                                       ($el:ptr $tail:ptr))))
+         ($vectorToList:top $vec:ptr $ntl:ptr $ni:int))))))
+
+(unit)