diff --git a/koka.cabal b/koka.cabal index 82c7bd3b4..ef8b0036e 100644 --- a/koka.cabal +++ b/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 diff --git a/lib/std/core.kk b/lib/std/core.kk index c012e7b07..3f0deb999 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -221,12 +221,12 @@ pub extern main-console : forall ( 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 : () -> () ) : () diff --git a/lib/std/core/console.kk b/lib/std/core/console.kk index 34b8afe54..3adfb2ed7 100644 --- a/lib/std/core/console.kk +++ b/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 : () -> ,console> a ) : (() -> console a) diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index f2f7c3f64..9f35b76b4 100644 --- a/lib/std/core/hnd.kk +++ b/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, y : marker ) : bool extern fresh-marker() : marker c inline "kk_marker_unique(kk_context())" js inline "$marker_unique++" + vm "!sexp:(fresh-label)" extern fresh-marker-named() : marker c inline "-kk_marker_unique(kk_context())" js inline "-($marker_unique++)" - + vm "!sexp:(fresh-label)" // ------------------------------------------- @@ -175,6 +177,7 @@ extern fresh-marker-named() : marker extern evv-insert( evv : evv, ev : ev ) : e1 evv 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 ) : string @@ -186,6 +189,7 @@ extern evv-show( evv : evv ) : string extern evv-eq(evv0 : evv, evv1 : evv ) : bool c "kk_evv_eq" js inline "(#1) === (#2)" + vm "ptr_eq" // ------------------------------------------- @@ -196,22 +200,26 @@ extern evv-eq(evv0 : evv, evv1 : evv ) : bool pub inline extern @evv-at ( i : ev-index ) : ev // 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( htag : htag ) : 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 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( w : evv ) : 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( w : evv ) : 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( w : evv ) : e evv 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 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 //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 //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 ) : e evv //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 ) : yld 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, clause : (resume-result -> e1 r) -> e1 r ) : e (() -> b) +noinline extern yield-to-prim( m : marker, clause : (resume-result -> e1 r) -> e1 r ) : e (() -> b) c "kk_yield_to" js "$std_core_hnd._yield_to" +extern @yield-to-prim-vm( m : marker, 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, clause : (resume-result -> 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, clause : (resume-result -> e1 r) - // val keep1 = guard(w0) // check the evidence is correctly restored f() +noinline fun @yield-to-vm( m : marker, 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, 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, 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, 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, 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) -> |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) -> |e> b): |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) -> |e> b ) : |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 clause1V,e::E,r::V> inline extern cast-clause0( f : (marker,ev) -> e1 b) : e ((marker,ev) -> e b) inline "#1" + vm "!sexp:(debugWrap \"cast-clause0\" $arg0:top)" inline extern cast-clause1( f : (marker,ev,a) -> e1 b) : e ((marker,ev,a) -> e b) inline "#1" @@ -604,7 +659,7 @@ fun protect-check( resumed : ref, k : resume-result -> 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 -> e r ) : e r +noinline fun protect( x : a, clause : (x:a, k: b -> e r) -> e r, k : resume-result -> 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 - 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 Clause1(fn(m,w,x){ yield-to(m, fn(k){ clause(x, fn(r){ k({r}) } ) }) }) diff --git a/lib/std/core/inline/hnd.mcore.sexp b/lib/std/core/inline/hnd.mcore.sexp new file mode 100644 index 000000000..cb70c8774 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/lib/std/core/inline/int.mcore.sexp b/lib/std/core/inline/int.mcore.sexp new file mode 100644 index 000000000..541bce62b --- /dev/null +++ b/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) \ No newline at end of file diff --git a/lib/std/core/inline/vector.mcore.sexp b/lib/std/core/inline/vector.mcore.sexp new file mode 100644 index 000000000..efd5cdb95 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/lib/std/core/int.kk b/lib/std/core/int.kk index f47a849f9..886c8b862 100644 --- a/lib/std/core/int.kk +++ b/lib/std/core/int.kk @@ -23,6 +23,7 @@ import std/core/types extern import c file "inline/int.h" js file "inline/int.js" + vm file "inline/int.mcore.sexp" pub fip fun order( i : int ) : order if i < 0 then Lt @@ -45,41 +46,48 @@ pub inline fip extern (==)(^x : int, ^y : int) : bool c "kk_integer_eq_borrow" cs inline "(#1 == #2)" js "$std_core_types._int_eq" + vm "infixEq(Int, Int): Boolean" // Are two integers not equal? pub inline fip extern (!=)(^x : int, ^y : int) : bool c "kk_integer_neq_borrow" cs inline "(#1 != #2)" js "$std_core_types._int_ne" + vm "infixNeq(Int, Int): Boolean" // Is the first integer smaller or equal to the second? pub inline fip extern (<=)(^x : int, ^y : int) : bool c "kk_integer_lte_borrow" cs inline "(#1 <= #2)" js "$std_core_types._int_le" + vm "infixLte(Int, Int): Boolean" // Is the first integer greater or equal to the second? pub inline fip extern (>=)(^x : int, ^y : int) : bool c "kk_integer_gte_borrow" cs inline "(#1 >= #2)" js "$std_core_types._int_ge" + vm "infixGte(Int, Int): Boolean" // Is the first integer smaller than the second? pub inline fip extern (<)(^x : int, ^y : int) : bool c "kk_integer_lt_borrow" cs inline "(#1 < #2)" js "$std_core_types._int_lt" + vm "infixLt(Int, Int): Boolean" // Is the first integer greater than the second? pub inline fip extern (>)(^x : int, ^y : int) : bool c "kk_integer_gt_borrow" cs inline "(#1 > #2)" js "$std_core_types._int_gt" + vm "infixGt(Int, Int): Boolean" inline fip extern int-add : (int,int) -> int c "kk_integer_add" cs inline "(#1 + #2)" js "$std_core_types._int_add" + vm "infixAdd(Int, Int): Int" // Add two integers. pub fip fun (+)(x : int, y : int ) : int @@ -89,6 +97,7 @@ inline fip extern int-sub : (int,int) -> int c "kk_integer_sub" cs inline "(#1 - #2)" js "$std_core_types._int_sub" + vm "infixSub(Int, Int): Int" // Substract two integers. pub fip fun (-)(x : int, y : int ) : int @@ -99,18 +108,21 @@ pub inline fip extern (*) : (int,int) -> int c "kk_integer_mul" cs inline "(#1 * #2)" js "$std_core_types._int_mul" + vm "infixMul(Int, Int): Int" // Euclidean-0 division of two integers. See also `divmod:(x : int, y : int) -> (int,int)`. pub inline fip extern (/)(x:int,y:int) : int c "kk_integer_div" cs "Primitive.IntDiv" js "$std_core_types._int_div" + vm "infixDiv(Int, Int): Int" // Euclidean modulus of two integers; always a non-negative number. See also `divmod:(x : int, y : int) -> (int,int)`. pub inline fip extern (%) : (int,int) -> int c "kk_integer_mod" cs "Primitive.IntMod" js "$std_core_types._int_mod" + vm "mod(Int, Int): Int" /* Euclidean-0 division & modulus. Euclidean division is defined as: For any `D` and `d` where ``d!=0`` , we have: @@ -135,6 +147,7 @@ pub fip extern divmod(x:int,y:int) : (int,int) c "kk_integer_div_mod_tuple" cs "Primitive.IntDivMod" js "$std_core_types._int_divmod" + vm "!sexp:(prim ($d:int $m:int) (\"divmod(Int, Int): Int, Int\" $arg0:int $arg1:int) (make $divmodPair $divmodPair ($d:int $m:int)))" pub fip fun negate(i : int) : int ~i @@ -144,24 +157,28 @@ pub inline fip extern (~)(i:int) : int c "kk_integer_neg" cs inline "(-#1)" js "$std_core_types._int_negate" + vm "neg(Int): Int" // Is this an odd integer? pub inline fip extern is-odd( i : int ) : bool c "kk_integer_is_odd" cs inline "!(#1.IsEven)" js "$std_core_types._int_isodd" + vm "!sexp:(\"infixEq(Int, Int): Boolean\" (\"mod(Int, Int): Int\" $arg0:int 2) 1)" // Is this equal to zero? pub inline fip extern is-zero( ^x : int) : bool c inline "kk_integer_is_zero_borrow(#1)" cs inline "(#1.IsZero)" js "$std_core_types._int_iszero" + vm "!sexp:(\"infixEq(Int, Int): Boolean\" $arg0:int 0)" // Return the absolute value of an integer. pub inline fip extern abs(i : int) : int c "kk_integer_abs" cs "BigInteger.Abs" js "$std_core_types._int_abs" + vm "abs(Int): Int" @@ -259,6 +276,7 @@ pub extern show( i : int ) : string c "kk_integer_to_string" cs inline "#1.ToString()" js inline "#1.toString()" + vm "show(Int): String" // Convert an int to a boolean, using `False` for 0 and `True` otherwise. pub fun bool( i : int ) : bool @@ -285,14 +303,14 @@ pub fip fun mbint( m : maybe ) : int // An empty string, or a string starting with white space will result in `Nothing` // A string can start with a `-` sign for negative numbers, // and with `0x` or `0X` for hexadecimal numbers (in which case the `hex` parameter is ignored). -pub fun parse-int( s : string, hex : bool = False) : maybe +pub noinline fun parse-int( s : string, hex : bool = False) : maybe s.xparse(hex) noinline extern xparse( s : string, hex : bool ) : maybe c "kk_integer_xparse" cs "Primitive.IntParse" js "_int_parse" - + vm "!sexp:($xparseImpl:(fun Pure (ptr int) ptr) $arg0:ptr $arg1:int)" // ---------------------------------------------------------------------------- diff --git a/lib/std/core/string.kk b/lib/std/core/string.kk index 4f4883737..bbad95800 100644 --- a/lib/std/core/string.kk +++ b/lib/std/core/string.kk @@ -44,6 +44,7 @@ pub inline extern (==) : (string,string) -> bool c "kk_string_is_eq" cs inline "(#1 == #2)" js inline "(#1 === #2)" + vm "infixEq(String, String): Boolean" // Are two strings not equal? pub inline extern (!=) : (string,string) -> bool diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 079fc4e17..a2b096e09 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -305,6 +305,7 @@ pub fip extern @make-ssize_t( i : int) : ssize_t // Append two strings pub extern (++)(x : string, y : string) : string c "kk_string_cat" + vm "infixConcat(String, String): String" inline "(#1 + #2)" @@ -337,18 +338,21 @@ pub inline extern ref( value : a) : alloc ref c "kk_ref_alloc" cs inline "new Ref<##1,##2>(#1)" js inline "{ value: #1 }" + vm "mkRef(Ptr): Ref[Ptr]" // Assign a new value to a reference. pub inline extern set( ^ref : ref, assigned : a) : > () c "kk_ref_set_borrow" cs inline "#1.Set(#2)" js inline "((#1).value = #2)" + vm "setRef(Ref[Ptr], Ptr): Unit" // Read the value of a reference. pub inline extern ref/(!) : forall ( ref : ref) -> |e> a with(hdiv) c "kk_ref_get" cs inline "#1.Value" js inline "#1.value" + vm "getRef(Ref[Ptr]): Ptr" // Modify the value of a reference. // This is especially useful when the reference contains a vector, because @@ -392,18 +396,21 @@ pub inline extern local-new(value:a) : |e> local-var c "kk_ref_alloc" cs inline "new Ref<##1,##2>(#1)" js inline "{ value: #1 }" + vm "mkRef(Ptr): Ref[Ptr]" // Assign a new value to a local variable pub inline extern local-set( ^v: local-var, assigned: a) : |e> () c "kk_ref_set_borrow" cs inline "#1.Set(#2)"; js inline "((#1).value = #2)" + vm "setRef(Ref[Ptr], Ptr): Unit" // Read the value of a local variable. pub inline extern local-get : forall (v: local-var) -> |e> a with(hdiv) c "kk_ref_get" cs inline "#1.Value"; js inline "((#1).value)"; + vm "getRef(Ref[Ptr]): Ptr" // _Internal_: if local mutation is unobservable, the `:local` effect can be erased by using the `local-scope` function. // See also: _State in Haskell, by Simon Peyton Jones and John Launchbury_. diff --git a/lib/std/core/vector.kk b/lib/std/core/vector.kk index a54dee712..9e3aac42f 100644 --- a/lib/std/core/vector.kk +++ b/lib/std/core/vector.kk @@ -18,6 +18,7 @@ import std/core/int extern import c file "inline/vector" js file "inline/vector.js" + vm file "inline/vector.mcore.sexp" // ---------------------------------------------------------------------------- // Vectors @@ -28,6 +29,7 @@ inline extern unsafe-idx( ^v : vector, index : ssize_t ) : total a c "kk_vector_at_borrow" cs inline "(#1)[#2]" js inline "(#1)[#2]" + vm "unsafeIndex(Array[Ptr], Int): Ptr" inline extern unsafe-assign : forall ( v : vector, i : ssize_t, x : a ) -> total () c "kk_vector_unsafe_assign" @@ -50,6 +52,7 @@ inline extern lengthz( ^v : vector ) : ssize_t c "kk_vector_len_borrow" cs inline "((#1).Length)" js inline "((#1).length)" + vm "length(Array[Ptr]): Int" // Create a new vector of length `n` with initial elements `init`` . extern vector-alloc(n : ssize_t, init : a) : e vector @@ -136,6 +139,7 @@ pub extern vlist( v : vector, tail : list = [] ) : list c "kk_vector_to_list" cs inline "Primitive.VList<##1>(#1,#2)" js inline "_vlist(#1,#2)" + vm "!sexp:($vectorToList:top $arg0:ptr $arg1:ptr (\"length(Array[Ptr]): Int\" $arg0:ptr))" // Convert a list to a vector. pub fun list/vector( xs : list ) : vector diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index e14d9a787..72fea70dd 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -41,12 +41,14 @@ pub inline fip extern int32( i : int) : int32 c "kk_integer_clamp32" cs "Primitive.IntToInt32" js "$std_core_types._int_clamp32" + vm "!sexp:$arg0:num" // Convert an `:int32` to an `:int`. pub inline fip extern int( i : int32 ) : int c "kk_integer_from_int" cs inline "(new BigInteger(#1))" js "$std_core_types._int_from_int32" + vm "!sexp:$arg0:num" /* // Convert a `:float64` to an `:int32`. The float64 is clamped to the @@ -101,37 +103,45 @@ pub fun show-hex32( i : int32, width : int = 8, use-capitals : bool = True, pre pub inline fip extern (==)(x : int32, y : int32) : bool inline "(#1 == #2)" js inline "(#1 === #2)" + vm "infixEq(Int, Int): Boolean" // Are two 32-bit integers not equal? pub inline fip extern (!=)(x : int32, y : int32) : bool inline "(#1 != #2)" js inline "(#1 !== #2)" + vm "infixNeq(Int, Int): Boolean" // Is the first 32-bit integer smaller or equal to the second? pub inline fip extern (<=)(x : int32, y : int32) : bool inline "(#1 <= #2)" + vm "infixLte(Int, Int): Boolean" // Is the first 32-bit integer larger or equal to the second? pub inline fip extern (>=)(x : int32, y : int32) : bool inline "(#1 >= #2)" + vm "infixGte(Int, Int): Boolean" // Is the first 32-bit integer smaller than the second? pub inline fip extern (<)(x : int32, y : int32) : bool inline "(#1 < #2)" + vm "infixLt(Int, Int): Boolean" // Is the first 32-bit integer larger than the second? pub inline fip extern (>)(x : int32, y : int32) : bool inline "(#1 > #2)" + vm "infixGt(Int, Int): Boolean" // Add two 32-bit integers. pub inline fip extern (+)(x : int32, y : int32) : int32 c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB js inline "((#1 + #2)|0)" + vm "infixAdd(Int, Int): Int" // Subtract two 32-bit integers. pub inline fip extern (-)(x : int32, y : int32) : int32 c inline "(int32_t)((uint32_t)#1 - (uint32_t)#2)" // avoid UB js inline "((#1 - #2)|0)" + vm "infixSub(Int, Int): Int" // Is the 32-bit integer negative? pub inline fip extern is-neg( i : int32 ) : bool diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 9101eb29c..6ae7c8149 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -44,6 +44,7 @@ extern os-get-argv() : ndet vector c "kk_os_get_argv" cs "System.Environment.GetCommandLineArgs" js inline "(typeof process !== 'undefined' ? process.argv : [])" + vm "getArgs(): Array[String]" // The unprocessed command line that was used to start this program. @@ -61,8 +62,10 @@ pub fun get-argv() : ndet list // The `arguments` list will be `["--flag","bla"]` pub fun get-args() : ndet list val is-node = (host() == "node") + val is-vm = (host() == "vm") match get-argv() Cons(x,xx) | is-node && x.path.stemname == "node" -> xx.drop(1) + xs | is-vm -> xs xs -> xs.drop(1) // Return the main OS name: windows, linux, macos, unix, posix, ios, tvos, watchos, unknown. diff --git a/src/Backend/VM/FromCore.hs b/src/Backend/VM/FromCore.hs new file mode 100644 index 000000000..081677c39 --- /dev/null +++ b/src/Backend/VM/FromCore.hs @@ -0,0 +1,884 @@ +----------------------------------------------------------------------------- +-- Copyright 2012-2021, Microsoft Research, Daan Leijen, Edsko de Vries. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +module Backend.VM.FromCore + ( vmFromCore ) + where + +import Platform.Config(version) +import Lib.Trace +import Control.Applicative hiding (empty) +import Control.Monad +import qualified Control.Monad.Fail as F +import Data.List ( intersperse, partition, nub ) +import Data.Char +import Data.Bifunctor (bimap) + +import qualified Data.Set as S + +import Type.Type +import qualified Type.Pretty as Pretty + +import Lib.PPrint +import Common.Name +import Common.NamePrim +import Common.Failure +import Common.Unique +import Common.Syntax + +import Core.Core +import Core.Pretty +import Core.CoreVar +import Data.Tuple (swap) + +type ConditionDoc = Doc -> Doc -- `cd thn` gets you the doc; expects to be in an alternative-choice + +debug :: Bool +debug = True + +externalNames :: [(TName, Doc)] +externalNames + = [] + +intTypes :: [Name] +intTypes = [nameTpSSizeT,nameInt16,nameInt64,nameInt32,nameSSizeT,nameInternalInt32,nameInternalSSizeT,nameIntPtrT,nameByte,nameTpEvIndex] + +-------------------------------------------------------------------------- +-- Generate JavaScript code from System-F core language +-------------------------------------------------------------------------- + +vmFromCore :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Doc +vmFromCore buildType mbMain imports core + = runAsm (Env moduleName penv externalNames) (genModule buildType mbMain imports core) + where + moduleName = coreProgName core + penv = Pretty.defaultEnv{ Pretty.context = moduleName, Pretty.fullNames = False } + +genModule :: BuildType -> Maybe (Name,Bool) -> [Import] -> Core -> Asm Doc +genModule buildType mbMain imports core + = do rememberDataInfos (coreProgTypeDefs core) + let externIncludes = concatMap (genExternInclude buildType) (coreProgExternals core) + impdecls <- genLoadLibs imports + decls0 <- genGroups True (coreProgDefs core) + decls1 <- genTypeDefs (coreProgTypeDefs core) + let -- `imports = coreProgImports core` is not enough due to inlined definitions + (mainEntry) = case mbMain of + Nothing -> appPrim "!undefined:is a library" [] (tpe "Unit") + Just (name,isAsync) + -> obj [ "op" .= str "Seq" + , "elems" .= list [ appPrim "!sexp:(\"setGlobal(String, Ptr): Unit\" \"current-evv\" (\"mkRef(Ptr): Ref[Ptr]\" (make $evv $nil ())))" [] (tpe "Unit") + , app (var (ppName name) (tFn "Effectful" [] (tpe "Unit"))) [] + ] + ] + return $ + obj + [ "metadata" .= + obj [ "generated by" .= str "Koka" + , "koka version" .= str version + , "program name" .= str (show (coreProgName core)) + ] + , "includes" .= list externIncludes + , "definitions" .= + list ( impdecls + ++ decls0 + ++ decls1 + ) + , "main" .= mainEntry + ] +--------------------------------------------------------------------------------- +-- Extern includes +--------------------------------------------------------------------------------- +genExternInclude :: BuildType -> External -> [Doc] +genExternInclude buildType (e@ExternalImport{}) = + case externalImportLookup VM buildType "include-inline" e of + Just content -> [obj ["format" .= str "sexp", "value" .= str content]] + Nothing -> [] +genExternInclude _ _ = [] + +--------------------------------------------------------------------------------- +-- Generate import definitions +--------------------------------------------------------------------------------- +libName imp = (var (str ("import$" ++ imp)) (tpe "Ptr")) +genLoadLibs :: [Import] -> Asm [Doc] +genLoadLibs imports = return $ map genLoadLib imports + where genLoadLib imp = let name = (if null (importPackage imp) then "." else importPackage imp) ++ "/" ++ (moduleNameToPath (importName imp)) in + def (libName (show $ importName imp)) + (obj [ "op" .= str "LoadLib" + , "path" .= obj [ "op" .= str "Literal", "type" .= tpe "String", "format" .= str "path", "value" .= str ("$0/" ++ name ++ ".rpyeffect")] + ]) +--------------------------------------------------------------------------------- +-- Translate types +--------------------------------------------------------------------------------- +transformType :: Type -> Doc +transformType (TVar _) = tpe "Top" -- erased +transformType (TForall _ _ t) = transformType t -- TODO do we need to thunk +transformType (TFun ps e t) = obj [ "op" .= str "Function" + , "params" .= list [ transformType pt | (_,pt) <- ps] + , "return" .= transformType t + , "purity" .= str "Effectful" -- TODO infer from e + ] +transformType (TCon c) | (typeConName c) `elem` intTypes = tpe "Int" +transformType (TCon c) | nameModule (typeConName c) == "std/core/types" = case (nameStem (typeConName c)) of + "unit" -> tpe "Unit" + "string" -> tpe "String" + "bool" -> tpe "Int" + "int" -> tpe "Int" + "int32" -> tpe "Int" + t -> obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show t) ] +transformType (TCon c) = obj [ "op" .= str "Ptr", "extern_ptr_name" .= (str $ show $ typeConName c) ] +transformType (TApp t as) = transformType t +transformType (TSyn _ _ t) = transformType t + +--------------------------------------------------------------------------------- +-- Generate mcore statements for value definitions +--------------------------------------------------------------------------------- + +genGroups :: Bool -> [DefGroup] -> Asm [Doc] +genGroups topLevel groups + = localUnique $ concat <$> mapM (genGroup topLevel) groups + +genGroup :: Bool -> DefGroup -> Asm [Doc] +genGroup topLevel group + = case group of + DefRec defs -> mapM (genDef topLevel) defs + DefNonRec def -> (:[]) <$> genDef topLevel def + +switchNames :: [(Name, Name)] +switchNames = + [ (nameHandle, nameHandleVM) + -- , (nameNamedHandle, nameNamedHandleVM) + , (nameYieldTo, nameYieldToVM) + , (nameProtect, nameProtectVM) + , (nameLocalVar, nameLocalVarVM) + ] + +genDef :: Bool -> Def -> Asm Doc +genDef topLevel (Def name tp expr vis sort inl rng comm) | name `elem` (map fst switchNames) + = do let Just nameNew = lookup name switchNames + let n = var (ppName nameNew) (transformType tp) + let e = ppName nameNew + v <- genExpr expr + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] +genDef topLevel (Def name tp expr vis sort inl rng comm) | name `elem` (map snd switchNames) + = do let Just nameNew = lookup name (map swap switchNames) + let n = var (ppName nameNew) (transformType tp) + let e = ppName nameNew + v <- genExpr expr + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] +genDef topLevel (Def name tp expr vis sort inl rng comm) + = do let n = var (ppName name) (transformType tp) + let e = ppName name + v <- genExpr expr + return $ edef n (debugWrap ("Def of " ++ show n) v) [e] + +--------------------------------------------------------------------------------- +-- Generate value constructors for each defined type +--------------------------------------------------------------------------------- + +genTypeDefs :: TypeDefGroups -> Asm [Doc] +genTypeDefs groups + = concat <$> mapM (genTypeDefGroup) groups + +genTypeDefGroup :: TypeDefGroup -> Asm [Doc] +genTypeDefGroup (TypeDefGroup tds) + = concat <$> mapM (genTypeDef) tds + +genTypeDef ::TypeDef -> Asm [Doc] +genTypeDef (Synonym {}) + = return [] +genTypeDef (Data info isExtend) + = do modName <- getModule + let (dataRepr, conReprs) = getDataRepr info + mapM ( \(c,repr) -> + do args <- mapM (\(n,t) -> genTName $ TName n t) (conInfoParams c) + let name = ppName (conInfoName c) + let tp = transformType $ conInfoType c + penv <- getPrettyEnv + let singletonValue val = def (var name (transformType (conInfoType c))) val + if (conInfoName c == nameTrue) + then return $ def (var name (tpe "Int")) $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= text "1" ] + else if (conInfoName c == nameFalse) + then return $ def (var name (tpe "Int")) $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= text "0" ] + else return $ case repr of + -- special +-- ConEnum{} +-- -> def (var name (tpe "Int")) $ debugWrap ("enum ") $ obj ["op" .= str "Literal", "type" .= tpe "Int", "value" .= int (conTag repr)] +-- ConSingleton{} | conInfoName c == nameOptionalNone +-- -> null +-- ConSingleton _ DataStructAsMaybe _ _ +-- -> null +-- ConSingleton _ DataAsMaybe _ _ +-- -> null +-- ConSingleton _ DataAsList _ _ +-- -> null + -- normal + _ -> genConstr penv c repr name tp args + ) $ zip (dataInfoConstrs $ info) conReprs + where + null = var (text "-1") (tpe "Ptr") + genConstr penv c repr name tp [] + = edef (var name tp) (debugWrap "genConstr" $ + obj [ "op" .= str "Construct" + , "type_tag" .= (getConTypeTag c) + , "tag" .= name + , "args" .= list [] + ]) + [name] + genConstr penv c repr name tp args + = edef (var name tp) (debugWrap "genConstr" $ + obj [ "op" .= str "Abs", "params" .= list args + , "body" .= obj [ "op" .= str "Construct" + , "type_tag" .= (getConTypeTag c) + , "tag" .= name + , "args" .= list args + ] + ]) + [name] + +getConTypeTag info = str $ show $ getTConName $ getReturn $ conInfoType info + where + getTConName (TCon c) = typeconName c +getReturn (TFun _ _ r) = getReturn r +getReturn (TForall _ _ t) = getReturn t +getReturn (TApp t _) = getReturn t +getReturn r = r + +--------------------------------------------------------------------------------- +-- Statements +--------------------------------------------------------------------------------- + +-- | Generates a statement from an expression by applying a return context (deeply) inside + +genExprStat expr + = case expr of + -- If expression is inlineable, inline it + _ | isInlineableExpr expr + -> do exprDoc <- genInline expr + return exprDoc + + caseExpr@(Case exprs branches) + -> do (defss, scrutinees) <- unzip <$> mapM (\e-> if isInlineableExpr e && isTypeBool (typeOf e) + then do d <- genInline e + return ([], d) + else do (sd,vn) <- genVarBinding e + vd <- genTName vn + return (sd, vd) + ) exprs + doc <- genMatch scrutinees branches (typeOf caseExpr) + return $ obj [ "op" .= str "LetRec" + , "definitions" .= list (concat defss) + , "body" .= doc + ] + + Let groups body + -> do defs <- genGroups False groups + body <- genExprStat body + return $ obj [ "op" .= str "LetRec" + , "definitions" .= list defs + , "body" .= body + ] + + -- Handling all other cases + _ -> do (exprDoc) <- genExpr expr + return exprDoc + +-- | Generates a statement for a match expression regarding a given return context +genMatch :: [Doc] -> [Branch] -> Type -> Asm Doc +genMatch scrutinees branches atTpe + = fmap (debugWrap "genMatch") $ do + case branches of + [] -> fail ("Backend.VM.FromCore.genMatch: no branch in match statement: " ++ show(scrutinees)) + [b] -> do (conds, d) <- genBranch scrutinees b + return $ debugWrap "genMatch: one case" $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list [(conjunction conds) d, (appPrim "non-exhaustive match" [] (tpe "Bottom"))] + ] + + bs + | all (\b-> length (branchGuards b) == 1) bs + && all (\b->isExprTrue $ guardTest $ head $ branchGuards b) bs + -> do xs <- mapM (genBranch scrutinees) bs + let bs = map (\(conds,d) -> (conjunction conds d)) xs + return $ debugWrap "genMatch: guard-free case" + $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list (bs ++ [appPrim "non-exhaustive match" [] (tpe "Bottom")]) + ] + + _ -> do bs <- mapM (genBranch scrutinees) branches + let ds = map (\(cds,stmts)-> conjunction cds stmts) bs + return $ obj [ "op" .= str "AlternativeChoice" + , "choices" .= list ds + ] + where + -- | Generates a statement for a branch with given return context + genBranch :: [Doc] -> Branch -> Asm ([ConditionDoc], Doc) + -- Regular catch-all branch generation + genBranch tnDocs branch@(Branch patterns guards) + = do modName <- getModule + (conditions, substs) <- bimap concat concat . unzip <$> mapM (genTest modName) (zip tnDocs patterns) + let se = withNameSubstitutions substs + + gs <- mapM (se . genGuard) guards + return (conditions, debugWrap ("genBranch: " ++ show substs) + $ obj [ "op" .= str "AlternativeChoice", "choices" .= list gs ]) + + genGuard :: Guard -> Asm Doc + genGuard (Guard t expr) + = do testE <- genExpr t + exprSt <- genExpr expr + let exprSt' = obj [ "op" .= str "The", "type" .= transformType atTpe, "term" .= exprSt ] + return $ if isExprTrue t + then exprSt' + else ifEqInt testE (text "1") exprSt' + + -- | Generates a list of boolish expression for matching the pattern + genTest :: Name -> (Doc, Pattern) -> Asm ([ConditionDoc], [(TName, Doc)]) + genTest modName (scrutinee,pattern) + = case pattern of + PatWild -> return $ ([], []) + PatVar tn pat + -> do (conds, substs) <- genTest modName (scrutinee,pat) + return (conds, (tn, scrutinee):substs) + PatLit (LitInt i) + -> return ([ifEqInt scrutinee (text (show i))], []) + PatLit lit@(LitString _) + -> let tmp = var (str "tmp") (tpe "Int") in + return ([(\thn -> obj [ "op" .= str "Primitive" + , "name" .= str "infixEq(String, String): Boolean" + , "args" .= list [scrutinee, ppLit lit] + , "returns" .= list [tmp] + , "rest" .= ifEqInt tmp (text "1") thn + ]) + ], []) + PatCon tn fields repr _ _ _ info skip --TODO: skip test ? + | getName tn == nameTrue + -> return ([ifEqInt scrutinee (text "1")], []) + | getName tn == nameFalse + -> return ([ifEqInt scrutinee (text "0")], []) + | otherwise + -> case repr of + -- special +-- ConEnum _ _ _ tag +-- -> return ([ifEqInt scrutinee (int tag)], []) +-- ConSingleton{} +-- | getName tn == nameOptionalNone +-- -> [ifNull scrutinee] +-- ConSingleton _ DataStructAsMaybe _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] +-- ConSingleton _ DataAsMaybe _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] +-- ConSingleton _ DataAsList _ _ +-- -> [ifNull scrutinee] -- <+> ppName (getName tn)] + _ -> do fieldNames <- (mapM (\(n,t) -> do x <- genVarName (asString $ ppName n) + return $ var x (transformType t)) (conInfoParams info)) + let conTest = ifCon scrutinee (getConTypeTag info) (str $ show $ conInfoName info) fieldNames + (fieldTests, subfieldSubsts) <- (bimap concat concat) . unzip <$> mapM + (\(field,fieldName) -> genTest modName (debugWrap ("genTest: normal: " ++ show field ++ " -> " ++ show fieldName) fieldName, field) ) + ( zip fields fieldNames ) + -- let fieldSubsts = zipWith (\(n,t) x -> (TName n t, x)) + -- (conInfoParams info) fieldNames + return ((conTest:fieldTests), subfieldSubsts) -- ++ fieldSubsts) + + ifEqInt :: Doc -> Doc -> ConditionDoc + ifEqInt scrutinee lit thn = obj [ "op" .= str "Switch" + , "scrutinee" .= scrutinee + , "cases" .= list [obj ["value" .= lit, "then" .= thn ]] + , "default" .= obj ["op" .= str "AlternativeFail"] + ] + + ifCon :: Doc -> Doc -> Doc -> [Doc] -> ConditionDoc + ifCon scrutinee tpt t fields thn = debugWrap ("ifCon@" ++ asString scrutinee ++ ": " ++ asString tpt ++ "." ++ asString t ++ "(" ++ asString (tupled fields) ++ ")") + $ obj [ "op" .= str "Match" + , "scrutinee" .= scrutinee + , "type_tag" .= tpt + , "clauses" .= list [obj ["tag" .= t, "params" .= list fields, "body" .= thn]] + , "default_clause" .= obj ["params" .= list [], "body" .= obj ["op" .= str "AlternativeFail"]] + ] + + -- | Takes a list of docs and concatenates them with logical and + conjunction :: [ConditionDoc] -> ConditionDoc + conjunction [] = id + conjunction (doc:docs) = doc . (conjunction docs) + +--------------------------------------------------------------------------------- +-- Expressions that produce statements on their way +--------------------------------------------------------------------------------- + +-- | Generates javascript statements and a javascript expression from core expression +genExpr :: Expr -> Asm Doc +genExpr expr + = -- trace ("genExpr: " ++ show expr) $ + fmap (debugWrap ("genExpr: " ++ show expr)) $ + case expr of + -- check whether the expression is pure an can be inlined + _ | isInlineableExpr expr -> genInline expr + + TypeApp e _ -> genExpr e + TypeLam _ e -> genExpr e + + -- handle not inlineable cases + App (Var tname _) [Lit (LitInt i)] | getName tname `elem` intTypes + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + + -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string + App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf + -> do conDoc <- genTName con + return $ notImplemented (text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") + + App f args + -> case extractList expr of + Just (xs,tl) -> genList xs tl + Nothing -> case extractExtern f of + Just (tname,formats) + -> case args of + [Lit (LitInt i)] | getName tname `elem` intTypes + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + _ -> -- genInlineExternal tname formats argDocs + do (argDocs) <- genExprs args + (doc) <- genExprExternal tname formats argDocs + if (getName tname == nameReturn) + then return (text "") + else return (doc) + Nothing + -> do lsDecls <- genExprs (f:args) + let (fdoc:docs) = lsDecls + return $ app fdoc docs + Let groups body + -> do decls1 <- genGroups False groups + (doc) <- genExpr body + return $ obj [ "op" .= str "LetRec" + , "definitions" .= list decls1 + , "body".= doc + ] + + c@(Case _ _) + -> genExprStat c + _ -> failure ("JavaScript.FromCore.genExpr: invalid expression:\n" ++ show expr) + +extractList :: Expr -> Maybe ([Expr],Expr) +extractList e + = let (elems,tl) = extract [] e + in if (length elems > 10) -- only use inlined array for larger lists + then Just (elems,tl) + else Nothing + where + extract acc expr + = case expr of + App (TypeApp (Con name info) _) [hd,tl] | getName name == nameCons + -> extract (hd:acc) tl + _ -> (reverse acc, expr) + +genList :: [Expr] -> Expr -> Asm Doc +genList elems tl + = do (docs) <- genExprs elems + (tdoc) <- genExpr tl + return (text "$std_core_vector.vlist" <.> tupled [list docs, tdoc]) + +genExprs :: [Expr] -> Asm [Doc] +genExprs exprs = mapM genExpr exprs + +-- | Introduces an additional let binding in core if necessary +-- The expression in the result is guaranteed to be a Var afterwards +genVarBinding :: Expr -> Asm ([Doc], TName) +genVarBinding expr + = case expr of + Var tn _ -> return $ ([], tn) + _ -> do name <- newVarName "x" + let tp = typeOf expr + val <- genExprStat expr + let defs = [def (var (ppName name) (transformType tp)) val] + return ( defs, TName name (typeOf expr) ) + +--------------------------------------------------------------------------------- +-- Pure expressions +--------------------------------------------------------------------------------- + +genPure :: Expr -> Asm Doc +genPure expr + = case expr of + TypeApp e _ -> genPure e + TypeLam _ e -> genPure e + Var name (InfoExternal formats) + -> genWrapExternal name formats -- unapplied inlined external: wrap as function + Var name info + -> genTName name + Con name repr | getName name == nameUnit + -> return $ obj [ "op" .= str "Literal", "type" .= transformType (tnameType name) ] + Con name repr | getName name == nameTrue + -> return $ obj [ "op" .= str "Literal", "value" .= text "1", "type" .= transformType (tnameType name) ] + Con name repr | getName name == nameFalse + -> return $ obj [ "op" .= str "Literal", "value" .= text "0", "type" .= transformType (tnameType name) ] + Con name repr + -> genTName name + Lit l + -> return $ ppLit l + Lam params eff body + -> do args <- mapM genTName params + bodyDoc <- genExprStat body + return $ debugWrap "genPure: pure lambda in core code" + $ obj [ "op" .= str "Abs" + , "params" .= list args + , "body" .= bodyDoc + ] + _ -> failure ("JavaScript.FromCore.genPure: invalid expression:\n" ++ show expr) + +-- | Generates an effect-free javasript expression +-- NOTE: Throws an error if expression is not guaranteed to be effectfree +genInline :: Expr -> Asm Doc +genInline expr + = -- trace "genInline" $ + case expr of + _ | isPureExpr expr -> genPure expr + TypeLam _ e -> genInline e + TypeApp e _ -> genInline e + App (TypeApp (Con name repr) _) [arg] | isConIso repr + -> genInline arg + App (Con _ repr) [arg] | isConIso repr + -> genInline arg + App f args + -> do argDocs <- mapM genInline args + case extractExtern f of + Just (tname,formats) + -> case args of + [Lit (LitInt i)] | getName tname `elem` intTypes + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + _ -> genExprExternal tname formats argDocs + Nothing + -> case (f,args) of + ((Var tname _),[Lit (LitInt i)]) | getName tname `elem` intTypes && isSmallInt i + -> return $ obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + _ -> do fdoc <- genInline f + return $ app fdoc argDocs + _ -> failure ("VM.FromCore.genInline: invalid expression:\n" ++ show expr) + +extractExtern :: Expr -> Maybe (TName,[(Target,String)]) +extractExtern expr + = case expr of + TypeApp (Var tname (InfoExternal formats)) targs -> Just (tname,formats) + Var tname (InfoExternal formats) -> Just (tname,formats) + _ -> Nothing + +-- not fully applied external gets wrapped in a function +genWrapExternal :: TName -> [(Target,String)] -> Asm Doc +genWrapExternal tname formats + = case (splitFunScheme (typeOf tname)) of + Just (_,_,pars,_,_) -> do + let ts = map snd pars + vs <- genVarNames ts + doc <- genExprExternal tname formats vs + return $ debugWrap "genWrapExternal" + $ obj [ "op" .= str "Abs" + , "params" .= list vs + , "body" .= doc + ] + Nothing -> return $ notImplemented $ text "Non-function external" + +-- special case: .cctx-hole-create +genExprExternal :: TName -> [(Target,String)] -> [Doc] -> Asm (Doc) +genExprExternal tname formats [] | getName tname == nameCCtxHoleCreate + = return $ notImplemented $ text $ show $ getName tname +genExprExternal tname formats argDocs0 + = let name = getName tname + format = getFormat tname formats + t = getReturn (tnameType tname) + in return $ appPrim format argDocs0 (transformType t) + +getFormat :: TName -> [(Target,String)] -> String +getFormat tname formats + = case lookupTarget VM formats of -- TODO: pass specific target from the flags + Nothing -> -- failure ("backend does not support external in " ++ show tname ++ ": " ++ show formats) + trace( "warning: backend does not support external in " ++ show tname ) $ + ("!undefined: " ++ (show tname)) + Just s -> s + +genTName :: TName -> Asm Doc +genTName tname + = do env <- getEnv + case lookup tname (substEnv env) of + Nothing -> genName (getName tname) (tnameType tname) + Just d -> return d + +genName :: Name -> Type -> Asm Doc +genName name tpe + = if (isQualified name) + then do modname <- getModule + if (qualifier name == modname) + then return $ var (ppName name) (transformType tpe) + else return $ obj [ "op" .= str "Qualified", "lib" .= libName (nameModule name), "name" .= ppName name, "type" .= transformType tpe ] + else return $ var (ppName name) (transformType tpe) + +genVarName :: String -> Asm Doc +genVarName s = do n <- newVarName s + return $ ppName n + +-- | Generates `i` fresh variables and delivers them as `Doc` right away +genVarNames :: [Type] -> Asm [Doc] +genVarNames ts = do ns <- newVarNames (length ts) + let tns = zipWith TName ns ts + mapM genTName tns + +--------------------------------------------------------------------------------- +-- Classification +--------------------------------------------------------------------------------- + +extractExternal :: Expr -> Maybe (TName, String, [Expr]) +extractExternal expr + = case expr of + App (TypeApp (Var tname (InfoExternal formats)) targs) args + -> Just (tname, format tname formats, args) + App var@(Var tname (InfoExternal formats)) args + -> Just (tname, format tname formats, args) + _ -> Nothing + where + format tn fs + = case lookupTarget (JS JsDefault) fs of -- TODO: pass real target from flags + Nothing -> failure ("backend does not support external in " ++ show tn ++ show fs) + Just s -> s + +isInlineableExpr :: Expr -> Bool +isInlineableExpr expr + = case expr of + TypeApp expr _ -> isInlineableExpr expr + TypeLam _ expr -> isInlineableExpr expr + App (Var _ (InfoExternal _)) args -> all isPureExpr args + {- + -- TODO: comment out for now as it may prevent a tailcall if inlined + App f args -> -- trace ("isInlineable f: " ++ show f) $ + isPureExpr f && all isPureExpr args + -- all isInlineableExpr (f:args) + && not (isFunExpr f) -- avoid `fun() {}(a,b,c)` ! + -- && getParamArityExpr f == length args + -} + _ -> isPureExpr expr + +isPureExpr :: Expr -> Bool +isPureExpr expr + = case expr of + TypeApp expr _ -> isPureExpr expr + TypeLam _ expr -> isPureExpr expr + Var n (InfoConField{}) -> False + Var n _ | getName n == nameReturn -> False -- make sure return will never be inlined + | otherwise -> True + Con _ _ -> True + Lit _ -> True + Lam _ _ _ -> True + _ -> False + +--------------------------------------------------------------------------------- +-- The assembly monad +--------------------------------------------------------------------------------- + +newtype Asm a = Asm { unAsm :: Env -> St -> (a, St)} + +instance Functor Asm where + fmap f (Asm a) = Asm (\env st -> case a env st of + (x,st') -> (f x, st')) + +instance Applicative Asm where + pure x = Asm (\env st -> (x,st)) + (<*>) = ap + +instance Monad Asm where + -- return = pure + (Asm a) >>= f = Asm (\env st -> case a env st of + (x,st1) -> case f x of + Asm b -> b env st1) +instance F.MonadFail Asm where + fail = failure + +runAsm :: Env -> Asm Doc -> Doc +runAsm initEnv (Asm asm) + = case asm initEnv initSt of + (doc,st) -> doc + +data St = St { uniq :: Int + , dataInfos :: [(Name,DataInfo)] + } + +data Env = Env { moduleName :: Name -- | current module + , prettyEnv :: Pretty.Env -- | for printing nice types + , substEnv :: [(TName, Doc)] -- | substituting names + } + +initSt = St 0 [] + +instance HasUnique Asm where + updateUnique f + = Asm (\env st -> (uniq st, st{ uniq = f (uniq st)})) + +getEnv + = Asm (\env st -> (env, st)) + +withEnv f (Asm asm) + = Asm (\env st -> asm (f env) st) + +localUnique asm + = do u <- updateUnique id + x <- asm + setUnique u + return x + +findDataInfo :: Name -> Asm (Maybe DataInfo) +findDataInfo n = Asm (\env st -> ((lookup n $ dataInfos st), st)) + +rememberDataInfos :: TypeDefGroups -> Asm () +rememberDataInfos = mapM_ onGroups + where onGroups (TypeDefGroup tds) = mapM_ onTypeDef tds + onTypeDef d = remember (typeDefDataInfo d) + remember d = Asm (\env st -> ((), st{dataInfos = (dataInfoName d, d):(dataInfos st)})) + +newVarName :: String -> Asm Name +newVarName s + = do u <- unique + return (newName ("@" ++ s ++ show u)) + +newVarNames :: Int -> Asm [Name] +newVarNames 0 = return [] +newVarNames i + = do n <- newVarName "x" + ns <- newVarNames (i - 1) + return (n:ns) + +getModule :: Asm Name +getModule + = do env <- getEnv + return (moduleName env) + +getPrettyEnv :: Asm Pretty.Env +getPrettyEnv + = do env <- getEnv + return (prettyEnv env) + +withNameSubstitutions :: [(TName, Doc)] -> Asm a -> Asm a +withNameSubstitutions subs asm + = withEnv (\env -> env{ substEnv = subs ++ substEnv env }) asm + +--------------------------------------------------------------------------------- +-- Pretty printing +--------------------------------------------------------------------------------- +ppLit :: Lit -> Doc +ppLit lit + = case lit of + LitInt i -> obj [ "op" .= str "Literal", "type" .= tpe "Int", "value" .= pretty i ] + LitChar c -> litStr [c] + LitFloat d -> obj [ "op" .= str "Literal", "type" .= tpe "Double", "value" .= text (showsPrec 20 d "") ] + LitString s -> litStr s +escape c + = if (c < ' ') + then (if (c=='\n') then text "\\n" + else if (c == '\r') then text "\\r" + else if (c == '\t') then text "\\t" + else text "\\u" <.> text (showHex 4 (fromEnum c))) + else if (c <= '~') + then (if (c == '\"') then text "\\\"" + else if (c=='\'') then text "\\'" + else if (c=='\\') then text "\\\\" + else char c) + else if (fromEnum c <= 0xFFFF) + then text "\\u" <.> text (showHex 4 (fromEnum c)) + else if (fromEnum c > 0x10FFFF) + then text "\\uFFFD" -- error instead? + else let code = fromEnum c - 0x10000 + hi = (code `div` 0x0400) + 0xD800 + lo = (code `mod` 0x0400) + 0xDC00 + in text ("\\u" ++ showHex 4 hi ++ "\\u" ++ showHex 4 lo) + +isSmallInt i = (i > minSmallInt && i < maxSmallInt) + +maxSmallInt, minSmallInt :: Integer +maxSmallInt = 9007199254740991 -- 2^53 - 1 +minSmallInt = -maxSmallInt + +ppName :: Name -> Doc +ppName name + = quoted $ if isQualified name + then ppModName (qualifier name) <.> text "/" <.> encode False (unqualify name) + else encode False name + +ppModName :: Name -> Doc +ppModName name = encode True (name) + +encode :: Bool -> Name -> Doc +encode isModule name + = text $ show name + +debugWrap :: String -> Doc -> Doc +debugWrap s d + = if debug then obj [ + "op" .= str "DebugWrap", + "inner" .= d, + "annotation" .= str s + ] else d + +quoted :: Doc -> Doc +quoted d = text $ show $ asString d + +str :: String -> Doc +str s = text $ show $ s + +obj :: [Doc] -> Doc +obj = encloseSep lbrace rbrace comma + +(.=) :: String -> Doc -> Doc +(.=) k v = text (show k ++ ":") <+> v + +-------------------------------------------------------------------------------- +-- Smart-constructors for instructions +-------------------------------------------------------------------------------- +app :: Doc -> [Doc] -> Doc +app fn args = obj [ "op" .= str "App" + , "fn" .= fn + , "args" .= list args + ] + +primitive :: [Doc] -> String -> [Doc] -> Doc -> Doc +primitive outs name ins body = obj + [ "op" .= str "Primitive" + , "name" .= str name + , "args" .= list ins + , "returns" .= list outs + , "rest" .= body + ] + +-- | Simplified primitive smart-constructor (works almost like function application) +appPrim :: String -- ^ name + -> [Doc] -- ^ args + -> Doc -- ^ return type + -> Doc +appPrim name args tp = primitive [var (str "primitive_result") tp] name args (var (str "primitive_result") tp) + +litStr :: String -> Doc +litStr s = obj [ "op" .= str "Literal", "type" .= tpe "String", "value" .= dquotes (hcat (map escape s)) ] + +-- | Pseudo-instruction for not-yet supported parts +notImplemented :: Doc -> Doc +notImplemented doc = appPrim ("!undefined: " ++ show (asString doc)) [] (tpe "Bottom") + +-- TODO other instructions + +var :: Doc -> Doc -> Doc +var x t = obj [ "op" .= str "Var", "id" .= x, "type" .= t ] + +---- Types +tFn :: String -> [Doc] -> Doc -> Doc +tFn pur ps r = obj [ "op" .= text (show "Function") + , "params" .= list ps + , "return" .= r + , "purity" .= text (show pur) + ] + +-- | Simple named type +tpe :: String -> Doc +tpe name = obj [ "op" .= text (show name) ] + +---- Other forms + +-- | Definitions +def :: Doc -> Doc -> Doc +def n v = obj [ "name" .= n, "value" .= v ] +edef :: Doc -> Doc -> [Doc] -> Doc +edef n v es = obj [ "name" .= n, "value" .= v, "export_as" .= list es ] \ No newline at end of file diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index b5950799b..9362da199 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -49,10 +49,13 @@ module Common.NamePrim -- Effects , nameTpHTag, nameHTag - , nameTpClause, namePerform + , nameTpClause, namePerform, isNameTpClause , nameTpEvv, nameEvvAt, nameEvvIndex , nameOpenAt, nameOpen, nameOpenNone , nameTpEv, nameHandle, nameNamedHandle + , nameHandleVM, nameNamedHandleVM + , nameYieldTo, nameYieldToVM + , nameProtect, nameProtectVM , nameTpResumeContext , nameClause , nameIdentity @@ -151,6 +154,7 @@ module Common.NamePrim , nameTpRef, nameRef , nameTpLocalVar, nameTpLocal , nameLocalVar, nameRunLocal, nameLocalSet, nameLocalGet, nameLocalNew + , nameLocalVarVM , nameTpOptional @@ -333,6 +337,12 @@ nameEvvIsAffine = coreHndName ("@evv-is-affine") nameHandle = coreHndName "@hhandle" nameNamedHandle = coreHndName "@named-handle" +nameHandleVM = coreHndName "@hhandle-vm" +nameNamedHandleVM = coreHndName "@named-handle-vm" +nameYieldTo = coreHndName "yield-to" +nameYieldToVM = coreHndName "@yield-to-vm" +nameProtect = coreHndName "protect" +nameProtectVM = coreHndName "@protect-vm" nameYielding = coreHndName "yielding" nameYieldExtend = coreHndName "yield-extend" @@ -353,6 +363,14 @@ isClauseTailName name then Just (read (drop 11 s)) else Nothing +isNameTpClause :: Name -> Maybe Int +isNameTpClause name | nameModule name /= nameModule nameCoreHnd = Nothing +isNameTpClause name + = let s = nameLocal name + in if (s `startsWith` "clause" && all isDigit (drop 6 s)) + then Just (read (drop 6 s)) + else Nothing + {-------------------------------------------------------------------------- std/core/types --------------------------------------------------------------------------} @@ -382,6 +400,7 @@ nameTpLocal = coreTypesName "local" nameRef = coreTypesName "ref" nameLocalNew = coreTypesName "local-new" nameLocalVar = coreHndName "local-var" +nameLocalVarVM = coreHndName "local-var-vm" nameRunLocal = coreTypesName "local-scope" nameTpTotal = nameEffectEmpty -- coreTypesName "total" diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index 69192e31d..b6de2b918 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -42,7 +42,7 @@ import Data.List(intersperse) data JsTarget = JsDefault | JsNode | JsWeb deriving (Eq,Ord) data CTarget = CDefault | LibC | Wasm | WasmJs | WasmWeb deriving (Eq,Ord) -data Target = CS | JS !JsTarget| C !CTarget | Default deriving (Eq,Ord) +data Target = CS | JS !JsTarget| C !CTarget | VM | Default deriving (Eq,Ord) isTargetC (C _) = True isTargetC _ = False @@ -50,6 +50,9 @@ isTargetC _ = False isTargetJS (JS _) = True isTargetJS _ = False +isTargetVM VM = True +isTargetVM _ = False + isTargetWasm :: Target -> Bool isTargetWasm target = case target of @@ -70,6 +73,7 @@ instance Show Target where C WasmWeb-> "wasmweb" C LibC -> "libc" C _ -> "c" + VM -> "vm" Default -> "" data Platform = Platform{ sizePtr :: !Int -- sizeof(intptr_t) @@ -423,6 +427,3 @@ instance Show Fip where showTail True = "tail " showTail _ = " " - - - diff --git a/src/Compile/CodeGen.hs b/src/Compile/CodeGen.hs index 833051f05..09fd8ccae 100644 --- a/src/Compile/CodeGen.hs +++ b/src/Compile/CodeGen.hs @@ -42,6 +42,7 @@ import Core.Borrowed( Borrowed ) import Backend.CSharp.FromCore ( csharpFromCore ) import Backend.JavaScript.FromCore( javascriptFromCore ) import Backend.C.FromCore ( cFromCore ) +import Backend.VM.FromCore ( vmFromCore ) import Compile.Options import Compile.Module( Definitions(..), Module(..), modCoreImports ) @@ -142,6 +143,7 @@ codeGen term flags sequential newtypes borrowed kgamma gamma entry imported mod backend = case target flags of CS -> codeGenCS JS _ -> codeGenJS + VM -> codeGenVM _ -> {- let -- for Perceus (Parc) we analyze types inside abstract types and thus need -- access to all defined types; here we freshly extract all type definitions from all @@ -261,6 +263,29 @@ codeGenJS term flags sequential entry outBase core return (\_ -> return (LinkExe outjs (runCommand term flags [node flags,"--stack-size=" ++ show stksize,outjs]))) +{--------------------------------------------------------------- + VM backend +---------------------------------------------------------------} + +codeGenVM :: Terminal -> Flags -> (IO () -> IO ()) -> Maybe (Name,Type) -> FilePath -> Core.Core -> IO Link +codeGenVM term flags sequential entry outBase core + = do let outmcore = outBase ++ ".mcore.json" + let outrpy = outBase ++ ".rpyeffect" + vm = vmFromCore (buildType flags) mbEntry (Core.coreProgImports core) core + mbEntry = case entry of + Just (name,tp) -> Just (name,isAsyncFunction tp) + _ -> Nothing + termTrace term ( "generate vm: " ++ outmcore ) + writeDocW 80 outmcore vm + when (showAsmVM flags) (termInfo term vm) + + -- FIXME: for now, use debug flags + runCommand term flags [rpyeffectAsm flags,"--from", "mcore-json", outmcore, outrpy] -- for debugging: "--debug", "--check-contracts", + + case mbEntry of + Nothing -> return noLink + Just _ -> + return (\_ -> return (LinkExe outmcore (runCommand term flags [rpyeffectJit flags,outrpy]))) {--------------------------------------------------------------- C backend diff --git a/src/Compile/Optimize.hs b/src/Compile/Optimize.hs index aa7e1a1a1..6ee4279cf 100644 --- a/src/Compile/Optimize.hs +++ b/src/Compile/Optimize.hs @@ -19,7 +19,7 @@ import Common.Error import Common.Range import Common.Unique import Common.Name -import Common.NamePrim( isPrimitiveModule, isPrimitiveName, nameCoreHnd ) +import Common.NamePrim( isPrimitiveModule, isPrimitiveName, nameCoreHnd, nameLocalVar ) import Common.Syntax import qualified Common.NameSet as S import Core.Pretty( prettyDef ) @@ -58,6 +58,7 @@ coreOptimize flags newtypes gamma inlines coreProgram let progName = Core.coreProgName coreProgram penv = prettyEnvFromFlags flags checkCoreDefs title = when (coreCheck flags) $ Core.Check.checkCore False False penv gamma + vmInlineFilter = if (target flags == VM) then (\n -> n `notElem` [nameLocalVar]) else const True -- when (show progName == "std/text/parse") $ -- trace ("compile " ++ show progName ++ ", gamma: " ++ showHidden gamma) $ return () @@ -77,7 +78,7 @@ coreOptimize flags newtypes gamma inlines coreProgram when (optInlineMax flags > 0) $ do let inlinesX = if isPrimitiveModule progName then inlines else inlinesFilter (\name -> nameModule nameCoreHnd /= nameModule name) inlines - inlineDefs penv (2*(optInlineMax flags)) inlinesX + inlineDefs penv (2*(optInlineMax flags)) (inlinesFilter vmInlineFilter inlinesX) -- checkCoreDefs "inlined" simplifyDupN @@ -112,6 +113,9 @@ coreOptimize flags newtypes gamma inlines coreProgram -- trace (show progName ++ ": monadic transform") $ do Core.Monadic.monTransform penv openResolve penv gamma -- must be after monTransform + + when (target flags == VM) $ openResolve penv gamma + checkCoreDefs "monadic transform" -- simplify open applications (needed before inlining open defs) @@ -126,7 +130,7 @@ coreOptimize flags newtypes gamma inlines coreProgram -- now inline primitive definitions (like yield-bind) let inlinesX = inlinesFilter isPrimitiveName inlines -- trace ("inlines2: " ++ show (map Core.inlineName (inlinesToList inlinesX))) $ - inlineDefs penv (2*optInlineMax flags) inlinesX -- (loadedInlines loaded) + inlineDefs penv (2*optInlineMax flags) (inlinesFilter vmInlineFilter inlinesX) -- (loadedInlines loaded) -- remove remaining open calls; this may change effect types simplifyDefs penv True {-unsafe-} ndebug (simplify flags) 0 -- remove remaining .open diff --git a/src/Compile/Options.hs b/src/Compile/Options.hs index 98aa31498..fa9ba5af3 100644 --- a/src/Compile/Options.hs +++ b/src/Compile/Options.hs @@ -125,6 +125,7 @@ data Flags , showCoreTypes :: !Bool , showAsmCS :: !Bool , showAsmJS :: !Bool + , showAsmVM :: !Bool , showAsmC :: !Bool , _showTypeSigs :: !Bool , showHiddenTypeSigs :: !Bool @@ -150,6 +151,8 @@ data Flags , csc :: !FileName , node :: !FileName , wasmrun :: !FileName + , rpyeffectAsm :: !FileName + , rpyeffectJit :: !FileName , cmake :: !FileName , cmakeArgs :: !String , ccompPath :: !FilePath @@ -268,6 +271,7 @@ flagsNull False -- show asm False False + False False -- typesigs False -- hiddentypesigs False -- show elapsed time @@ -292,6 +296,8 @@ flagsNull "csc" "node" "wasmtime" + "../rpyeffect-asm/target/universal/stage/bin/rpyeffectasm" -- TODO hardcoded for now (for testing) + "../rpyeffect-jit/out/bin/arm64-Darwin/rpyeffect-jit" -- TODO hardcoded for now (for testing) "cmake" "" -- cmake args @@ -424,6 +430,8 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , option [] ["csc"] (ReqArg cscFlag "cmd") "use as the csharp backend compiler " , option [] ["node"] (ReqArg nodeFlag "cmd") "use to execute node" , option [] ["wasmrun"] (ReqArg wasmrunFlag "cmd") "use to execute wasm" + , option [] ["rpyeffect-asm"] (ReqArg rpyeffectAsmFlag "cmd") "use to compile rpyeffect-asm mcore to rpyeffect" + , option [] ["rpyeffect-jit"] (ReqArg rpyeffectJitFlag "cmd") "use to run rpyeffect code" , option [] ["editor"] (ReqArg editorFlag "cmd") "use as editor" , option [] ["stack"] (ReqArg stackFlag "size") "set stack size (0 for platform default)" , option [] ["heap"] (ReqArg heapFlag "size") "set reserved heap size (0 for platform default)" @@ -450,6 +458,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip , flag [] ["showcoretypes"] (\b f -> f{showCoreTypes=b}) "show full types in core" , flag [] ["showcs"] (\b f -> f{showAsmCS=b}) "show generated c#" , flag [] ["showjs"] (\b f -> f{showAsmJS=b}) "show generated javascript" + , flag [] ["showvm"] (\b f -> f{showAsmVM=b}) "show generated rpyeffect-asm mcore" , flag [] ["showc"] (\b f -> f{showAsmC=b}) "show generated C" , flag [] ["core"] (\b f -> f{genCore=b}) "generate a core file" , flag [] ["checkcore"] (\b f -> f{coreCheck=b}) "check generated core" @@ -612,6 +621,12 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip wasmrunFlag s = Flag (\f -> f{ wasmrun = s }) + rpyeffectAsmFlag s + = Flag (\f -> f{ rpyeffectAsm = s }) + + rpyeffectJitFlag s + = Flag (\f -> f{ rpyeffectJit = s }) + editorFlag s = Flag (\f -> f{ editor = s }) @@ -674,7 +689,8 @@ targets = ("wasm64", \f -> f{ target=C Wasm, platform=platform64 }), ("wasmjs", \f -> f{ target=C WasmJs, platform=platform32 }), ("wasmweb",\f -> f{ target=C WasmWeb, platform=platform32 }), - ("cs", \f -> f{ target=CS, platform=platformCS }) + ("cs", \f -> f{ target=CS, platform=platformCS }), + ("vm", \f -> f{ target=VM, platform=platform64, enableMon = False, optctail = False }) ] -- | Environment table @@ -1045,6 +1061,7 @@ targetExeExtension target C _ -> exeExtension JS JsWeb -> ".html" JS _ -> ".mjs" + VM -> ".mcore.json" _ -> exeExtension targetObjExtension target @@ -1054,6 +1071,7 @@ targetObjExtension target C WasmWeb-> ".o" C _ -> objExtension JS _ -> ".mjs" + VM -> ".mcore.json" _ -> objExtension targetLibFile target fname @@ -1063,6 +1081,7 @@ targetLibFile target fname C WasmWeb-> "lib" ++ fname ++ ".a" C _ -> libPrefix ++ fname ++ libExtension JS _ -> fname ++ ".mjs" -- ? + VM -> fname ++ ".rpyeffect" _ -> libPrefix ++ fname ++ libExtension outName :: Flags -> FilePath -> FilePath diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 073ea2cc2..0b48881da 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -363,6 +363,9 @@ externalTarget <|> do specialId "js" return (JS JsDefault) + <|> + do specialId "vm" + return VM <|> return Default diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index 55f26cec3..67b3f0100 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -200,6 +200,7 @@ ppTarget env target CS -> text "cs " C _ -> text "c " JS _ -> text "js " + VM -> text "vm " -- _ -> keyword env (show target) <.> space diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index b3b02d0b7..ec229b314 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -434,6 +434,7 @@ formatCall tp (target,ExternalInline inline) = (target,inline) formatCall tp (target,ExternalCall fname) = case target of CS -> (target,formatCS) + VM -> (target,formatVM) JS _ -> (target,formatJS) C _ -> (target,formatC) Default -> (target,formatJS) @@ -455,6 +456,9 @@ formatCall tp (target,ExternalCall fname) formatJS = fname ++ arguments + formatVM + = fname + formatCS = fname ++ typeArguments ++ arguments diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index d53c52e5b..27fa612c3 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -566,6 +566,9 @@ externalTarget <|> do specialId "cs" return CS + <|> + do specialId "vm" + return VM <|> do specialId "js" return (JS JsDefault) diff --git a/stack.yaml b/stack.yaml index 98a196bd3..beb20a567 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,6 +13,7 @@ # $ cabal new-run koka # See also . +arch: aarch64 resolver: lts-22.11 # ghc 9.6.4 -- on windows set the codepage to utf-8: `chcp 65001` # resolver: lts-21.24 # ghc 9.4.8 diff --git a/test/Spec.hs b/test/Spec.hs index 68e53cbca..b8c68e356 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -211,6 +211,8 @@ processOptions arg (options,hargs) then (options{target="js"}, hargs) else if (arg == "--target-c64c") then (options{target="c64c"}, hargs) + else if (arg == "--target-vm") + then (options{ target="vm" }, hargs) else if (arg == "--seq") then (options{par=False}, hargs) else (options, arg : hargs) diff --git a/test/minimal/hello.kk b/test/minimal/hello.kk new file mode 100644 index 000000000..3f830cedf --- /dev/null +++ b/test/minimal/hello.kk @@ -0,0 +1,5 @@ +extern doprint(s : string) : () + vm "println(String): Unit" + +pub fun main() + doprint("Hello")