add ffi/unsafe/vm

Provide `vm-primitive` and `vm-eval` to regularize access to VM-level
primitives. Document some of the issues for interoperating across the
Racket and (Chez Scheme) VM layers.

The library could have been implemented with just `compile-linklet`
and `instantiate-linklet`, but using an underlying `primitive-lookup`
function is a little nicer.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.6.0.6")
+(define version "7.6.0.7")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/foreign/derived.scrbl

@@ -24,3 +24,4 @@
 @include-section["com.scrbl"]
 @include-section["file.scrbl"]
 @include-section["winapi.scrbl"]
+@include-section["vm.scrbl"]

pkgs/racket-doc/scribblings/foreign/vm.scrbl

@@ -0,0 +1,102 @@
+#lang scribble/doc
+@(require "utils.rkt" (for-label ffi/unsafe/vm
+                                 racket/linklet))
+
+@title[#:tag "vm"]{Virtual Machine Primitives}
+
+@defmodule[ffi/unsafe/vm]{The
+@racketmodname[ffi/unsafe/vm] library provides access to functionality
+in the underlying virtual machine that is used to implement Racket.}
+
+@history[#:added "7.6.0.7"]
+
+@defproc[(vm-primitive [name symbol?]) any/c]{
+
+Accesses a primitive values at the level of the running Racket virtual
+machine, or returns @racket[#f] if @racket[name] is not the name of a
+primitive.
+
+Virtual-machine primitives are the ones that can be referenced in a
+@tech[#:doc reference.scrbl]{linklet} body. The specific set of
+primitives depends on the virtual machine. Many ``primitives'' at the
+@racketmodname[racket/base] level are not primitives at the
+virtual-machine level. For example, if @racket['eval] is available as
+a primitive, it is not the @racket[eval] from
+@racketmodname[racket/base].
+
+In general, primitives are unsafe and can only be used with enough
+knowledge about Racket's implementation. Here are some tips for
+currently available virtual machines:
+
+@itemlist[
+
+ @item{@racket[(system-type 'vm)] is @racket['racket] --- The
+       primitives in this virtual machine are mostly the same as the
+       ones available from libraries like @racketmodname[racket/base]
+       and @racketmodname[racket/unsafe/ops]. As a result, accessing
+       virtual machine primitives with @racket[vm-primitive] is rarely
+       useful.}
+
+ @item{@racket[(system-type 'vm)] is @racket['chez-scheme] --- The
+       primitives in this virtual machine are Chez Scheme primitives,
+       except as replaced by a Racket compatibility layer. The
+       @racket['eval] primitive is Chez Scheme's @racketidfont{eval}.
+
+       Beware of directly calling a Chez Scheme primitive that uses
+       Chez Scheme parameters or @racketidfont{dynamic-wind}
+       internally. Note that @racketidfont{eval}, in particular, is
+       such a primitive. The problem is that Chez Scheme's
+       @racketidfont{dynamic-wind} does not automatically cooperate
+       with Racket's continuations or threads. To call such
+       primitives, use the @racketidfont{call-with-system-wind}
+       primitive, which takes a procedure of no arguments to run in a
+       context that bridges Chez Scheme's @racketidfont{dynamic-wind}
+       and Racket continuations and threads. For example,
+
+       @racketblock[
+         (define primitive-eval (vm-primitive 'eval))
+         (define call-with-system-wind (vm-primitive 'call-with-system-wind))
+         (define (vm-eval s)
+           (call-with-system-wind
+            (lambda ()
+             (primitive-eval s))))
+       ]
+
+       is how @racket[vm-eval] is implemented on Chez Scheme.
+
+       Symbols, numbers, booleans, pairs, vectors, boxes, strings,
+       byte strings (i.e., bytevectors), and structures (i.e.,
+       records) are interchangeable between Racket and Chez Scheme. A
+       Chez Scheme procedure is a Racket procedure, but not all Racket
+       procedures are Chez Scheme procedures. To call a Racket
+       procedure from Chez Scheme, use the @racketidfont{#%app} form
+       that is defined in the Chez Scheme environment when it hosts
+       Racket.
+
+       Note that you can access Chez Scheme primitives, includes ones
+       that are shadowed by Racket's primitives, through the Chez
+       Scheme @racketidfont{$primitive} form. For example,
+       @racket[(vm-eval '($primitive call-with-current-continuation))]
+       accesses the Chez Scheme
+       @racketidfont{call-with-current-continuation} primitive instead
+       of Racket's replacement (where the replacement works with
+       Racket continuations and threads).}
+
+]}
+
+@defproc[(vm-eval [s-expr any/c]) any/c]{
+
+Evaluates @racket[s-expr] using the most primitive available evaluator:
+
+@itemlist[
+
+ @item{@racket[(system-type 'vm)] is @racket['racket] --- Uses
+       @racket[compile-linklet] and @racket[instantiate-linklet].}
+
+ @item{@racket[(system-type 'vm)] is @racket['chez-scheme] --- Uses
+       Chez Scheme's @racketidfont{eval}.}
+
+]
+
+See @racket[vm-primitive] for some information about bow
+virtual-machine primitives interact with Racket.}

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -805,6 +805,7 @@
     [else
      (error 'zo-parse "bad file format specifier")]))
 
+;; returns a hash table representing linklet bundle content
 (define (zo-parse-top port vm [check-end? #t])
 
   ;; Skip module hash code

racket/collects/ffi/unsafe/vm.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+(require '#%linklet)
+
+(provide (protect-out vm-primitive
+                      vm-eval))
+
+(define (vm-primitive sym)
+  (unless (symbol? sym)
+    (raise-syntax-error 'vm-primitive "symbol?" sym))
+  (primitive-lookup sym))
+
+(define (vm-eval s)
+  (case (system-type 'vm)
+    [(chez-scheme)
+     (define primitive-eval (vm-primitive 'eval))
+     (define call-with-system-wind (vm-primitive 'call-with-system-wind))
+     (call-with-system-wind
+      (lambda ()
+        (primitive-eval s)))]
+    [else
+     (instantiate-linklet (compile-linklet `(linklet () () ,s))
+                          null
+                          (make-instance 'eval))]))

racket/src/cs/linklet.sls

@@ -42,6 +42,7 @@
           primitive->compiled-position
           compiled-position->primitive
           primitive-in-category?
+          primitive-lookup
 
           omit-debugging?             ; not exported to racket
           platform-independent-zo-mode? ; not exported to racket
@@ -150,6 +151,15 @@
   (define (compiled-position->primitive pos) #f)
   (define (primitive-in-category? sym cat) #f)
 
+  (define (primitive-lookup sym)
+    (unless (symbol? sym)
+      (raise-argument-error 'primitive-lookup "symbol?" sym))
+    (call-with-system-wind
+     (lambda ()
+       (guard
+        (c [else #f])
+        (eval sym)))))
+
   (define root-logger (|#%app| current-logger))
 
   (define omit-debugging? (not (getenv "PLT_CS_DEBUG")))

racket/src/cs/primitive/linklet.ss

@@ -18,6 +18,7 @@
   [make-instance (known-procedure -2)]
   [primitive->compiled-position (known-procedure 2)]
   [primitive-table (known-procedure 6)]
+  [primitive-lookup (known-procedure 2)]
   [linklet-virtual-machine-bytes (known-procedure 1)]
   [read-linklet-bundle-hash (known-procedure 2)]
   [write-linklet-bundle-hash (known-procedure 2)]

racket/src/expander/run/linklet-operation.rkt

@@ -13,6 +13,7 @@
               primitive->compiled-position
               compiled-position->primitive
               primitive-in-category?
+              primitive-lookup
               
               linklet?
               compile-linklet             ; result is serializable

racket/src/expander/run/linklet.rkt

@@ -135,6 +135,8 @@
 (define (compiled-position->primitive pos) #f)
 (define (primitive-in-category? name cat-sym) #f)
 
+(define (primitive-lookup sym) #f)
+
 ;; ----------------------------------------
 
 (struct variable-reference (instance primitive-varref))

racket/src/racket/src/linklet.c

@@ -32,6 +32,7 @@ static Scheme_Object *primitive_table(int argc, Scheme_Object **argv);
 static Scheme_Object *primitive_to_position(int argc, Scheme_Object **argv);
 static Scheme_Object *position_to_primitive(int argc, Scheme_Object **argv);
 static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv);
+static Scheme_Object *primitive_lookup(int argc, Scheme_Object **argv);
 
 static Scheme_Object *linklet_p(int argc, Scheme_Object **argv);
 static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv);
@@ -130,6 +131,7 @@ void scheme_init_linklet(Scheme_Startup_Env *env)
   ADD_IMMED_PRIM("primitive->compiled-position", primitive_to_position, 1, 1, env);
   ADD_IMMED_PRIM("compiled-position->primitive", position_to_primitive, 1, 1, env);
   ADD_IMMED_PRIM("primitive-in-category?", primitive_in_category_p, 2, 2, env);
+  ADD_IMMED_PRIM("primitive-lookup", primitive_lookup, 1, 1, env);
 
   ADD_FOLDING_PRIM("linklet?", linklet_p, 1, 1, 1, env);
   ADD_PRIM_W_ARITY2("compile-linklet", compile_linklet, 1, 5, 2, 2, env);
@@ -310,6 +312,18 @@ static Scheme_Object *primitive_in_category_p(int argc, Scheme_Object **argv)
   return (r ? scheme_true : scheme_false);
 }
 
+static Scheme_Object *primitive_lookup(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *v;
+
+  if (!SCHEME_SYMBOLP(argv[0]))
+    scheme_wrong_contract("primitive-lookup", "symbol?", 0, argc, argv);
+
+  v = scheme_hash_get(scheme_startup_env->all_primitives_table, argv[0]);
+
+  return (v ? v : scheme_false);
+}
+
 static Scheme_Object *linklet_p(int argc, Scheme_Object **argv)
 {
   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1464
+#define EXPECTED_PRIM_COUNT 1465
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 6
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 6
+#define MZSCHEME_VERSION_W 7
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x

racket/src/racket/src/startup.inc

@@ -12382,6 +12382,7 @@ static const char *startup_source =
 "(define-values(1/primitive->compiled-position) primitive->compiled-position)"
 "(define-values(1/compiled-position->primitive) compiled-position->primitive)"
 "(define-values(1/primitive-in-category?) primitive-in-category?)"
+"(define-values(1/primitive-lookup) primitive-lookup)"
 "(define-values(1/linklet?) linklet?)"
 "(define-values(1/compile-linklet) compile-linklet)"
 "(define-values(1/recompile-linklet) recompile-linklet)"
@@ -46163,7 +46164,7 @@ static const char *startup_source =
 "(void))"
 " new-s_0)))))))))))"
 "(case-lambda"
-"((s_0)(do-make-syntax-introducer_0 s_0 'flip))"
+"((s_0)(begin 'do-make-syntax-introducer(do-make-syntax-introducer_0 s_0 'flip)))"
 "((s_0 mode56_0)(do-make-syntax-introducer_0 s_0 mode56_0)))))))"
 "(define-values"
 "(1/make-syntax-delta-introducer)"
@@ -46313,7 +46314,10 @@ static const char *startup_source =
 "(void))"
 " new-s_0))))))))))"
 "(case-lambda"
-"((s_0)(make-syntax-delta-introducer_0 s_0 'add))"
+"((s_0)"
+"(begin"
+" 'make-syntax-delta-introducer"
+"(make-syntax-delta-introducer_0 s_0 'add)))"
 "((s_0 mode63_0)"
 "(make-syntax-delta-introducer_0"
 " s_0"
@@ -64985,6 +64989,8 @@ static const char *startup_source =
 " 1/compiled-position->primitive"
 " 'primitive-in-category?"
 " 1/primitive-in-category?"
+" 'primitive-lookup"
+" 1/primitive-lookup"
 " 'linklet?"
 " 1/linklet?"
 " 'compile-linklet"
@@ -72914,7 +72920,7 @@ static const char *startup_source =
 "(parsed-top-id4.1 id_0 b_0 #f)"
 " s_0)))))))))))))))))))))))"
 "(case-lambda"
-"((s_0 ctx_0)(...nder/expand/expr.rkt:562:1_0 s_0 ctx_0 #f))"
+"((s_0 ctx_0)(begin '...nder/expand/expr.rkt:562:1(...nder/expand/expr.rkt:562:1_0 s_0 ctx_0 #f)))"
 "((s_0 ctx_0 implicit-omitted?362_0)(...nder/expand/expr.rkt:562:1_0 s_0 ctx_0 implicit-omitted?362_0))))))"
 "(void"
 "(add-core-form!*"