From 69932f6f6772c11fcee7586853cdf044a9322fa6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 29 Jan 2020 11:03:29 -0700 Subject: [PATCH] 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 | 2 +- .../scribblings/foreign/derived.scrbl | 1 + pkgs/racket-doc/scribblings/foreign/vm.scrbl | 102 ++++++++++++++++++ pkgs/zo-lib/compiler/zo-parse.rkt | 1 + racket/collects/ffi/unsafe/vm.rkt | 23 ++++ racket/src/cs/linklet.sls | 10 ++ racket/src/cs/primitive/linklet.ss | 1 + racket/src/expander/run/linklet-operation.rkt | 1 + racket/src/expander/run/linklet.rkt | 2 + racket/src/racket/src/linklet.c | 14 +++ racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 2 +- racket/src/racket/src/startup.inc | 12 ++- 13 files changed, 167 insertions(+), 6 deletions(-) create mode 100644 pkgs/racket-doc/scribblings/foreign/vm.scrbl create mode 100644 racket/collects/ffi/unsafe/vm.rkt diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 7eb15ad834..72d9ba38de 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/pkgs/racket-doc/scribblings/foreign/derived.scrbl b/pkgs/racket-doc/scribblings/foreign/derived.scrbl index 8f7dbaec46..1bf21dcc18 100644 --- a/pkgs/racket-doc/scribblings/foreign/derived.scrbl +++ b/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"] diff --git a/pkgs/racket-doc/scribblings/foreign/vm.scrbl b/pkgs/racket-doc/scribblings/foreign/vm.scrbl new file mode 100644 index 0000000000..3b0a222f66 --- /dev/null +++ b/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.} diff --git a/pkgs/zo-lib/compiler/zo-parse.rkt b/pkgs/zo-lib/compiler/zo-parse.rkt index 6fef8b1baf..e04ac3ff14 100644 --- a/pkgs/zo-lib/compiler/zo-parse.rkt +++ b/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 diff --git a/racket/collects/ffi/unsafe/vm.rkt b/racket/collects/ffi/unsafe/vm.rkt new file mode 100644 index 0000000000..4786b15236 --- /dev/null +++ b/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))])) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 3e91975a4b..9326cefd6a 100644 --- a/racket/src/cs/linklet.sls +++ b/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"))) diff --git a/racket/src/cs/primitive/linklet.ss b/racket/src/cs/primitive/linklet.ss index d4e6478915..90b815d377 100644 --- a/racket/src/cs/primitive/linklet.ss +++ b/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)] diff --git a/racket/src/expander/run/linklet-operation.rkt b/racket/src/expander/run/linklet-operation.rkt index ffc31432a7..5b43683eaa 100644 --- a/racket/src/expander/run/linklet-operation.rkt +++ b/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 diff --git a/racket/src/expander/run/linklet.rkt b/racket/src/expander/run/linklet.rkt index 78b90b6503..3ce5ae55ea 100644 --- a/racket/src/expander/run/linklet.rkt +++ b/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)) diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c index 3d71b5ab17..95b85b0dd6 100644 --- a/racket/src/racket/src/linklet.c +++ b/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) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 543d24cc3a..741c8752f6 100644 --- a/racket/src/racket/src/schminc.h +++ b/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 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 9348185fe3..8194502c59 100644 --- a/racket/src/racket/src/schvers.h +++ b/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 diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 1c1eb8ae93..cae52b70b6 100644 --- a/racket/src/racket/src/startup.inc +++ b/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!*"