diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index e19e83916b..b4b119bd0b 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -3027,6 +3027,19 @@ case of module-leve bindings; it doesn't cover local bindings. (lambda (exn) (regexp-match? #rx"already required\n at: x\n in: \\(quote require-conflict-is-sourced-b\\)\n also provided by: \\(quote require-conflict-is-sourced-a\\)" (exn-message exn)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure the error is reasonable if `current-compile` +;; is used directly and the result abused: + +(parameterize ([current-compile + (let ([orig-compile (current-compile)]) + (lambda (stx im?) + (orig-compile stx #t)))]) ; #t argument sets up the abuse + (define c (compile '(module m racket/base))) + (err/rt-test (write c (open-output-bytes)) + exn:fail:contract? + #rx"write: linklet is not serializable")) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/cs/linklet/write.ss b/racket/src/cs/linklet/write.ss index e860d9ad2a..800f552b1b 100644 --- a/racket/src/cs/linklet/write.ss +++ b/racket/src/cs/linklet/write.ss @@ -20,6 +20,7 @@ [(not i) (values ht cross-machine)] [else (let-values ([(key v) (hash-iterate-key+value orig-ht i)]) + (when (linklet? v) (check-fasl-preparation v)) (let ([new-v (if (and (linklet? v) (pair? (linklet-paths v))) (adjust-cross-perparation @@ -46,3 +47,8 @@ (if (or (pair? p) (eq? p 'faslable-unsafe)) (set-linklet-preparation l 'faslable) l))) + +(define (check-fasl-preparation l) + (case (linklet-preparation l) + [(callable lazy) + (raise-arguments-error 'write "linklet is not serializable")])) diff --git a/racket/src/racket/src/linklet.c b/racket/src/racket/src/linklet.c index 5147fc971c..16a003010c 100644 --- a/racket/src/racket/src/linklet.c +++ b/racket/src/racket/src/linklet.c @@ -63,7 +63,7 @@ static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Sche Scheme_Object *name, Scheme_Object **_import_keys, Scheme_Object *get_import, - int unsafe_mode, int static_mode); + int unsafe_mode, int static_mode, int serializable); static Scheme_Object *_instantiate_linklet_multi(Scheme_Linklet *linklet, Scheme_Instance *instance, int num_instances, Scheme_Instance **instances, @@ -355,7 +355,8 @@ void extract_import_info(const char *who, int argc, Scheme_Object **argv, static void parse_compile_options(const char *who, int arg_pos, int argc, Scheme_Object **argv, - int *_unsafe, int *_static_mode) + int *_unsafe, int *_static_mode, + int *_serializable) { Scheme_Object *redundant = NULL, *flag, *flags = argv[arg_pos]; int serializable = 0; @@ -404,14 +405,13 @@ static void parse_compile_options(const char *who, int arg_pos, *_unsafe = unsafe; *_static_mode = static_mode; + *_serializable = serializable; } static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv) { Scheme_Object *name, *e, *import_keys, *get_import, *a[2]; - int unsafe = 0, static_mode = 0; - - /* Last argument, `serializable?`, is ignored */ + int unsafe = 0, static_mode = 0, serializable = 1; extract_import_info("compile-linklet", argc, argv, &import_keys, &get_import); @@ -432,10 +432,10 @@ static Scheme_Object *compile_linklet(int argc, Scheme_Object **argv) } if (argc > 4) - parse_compile_options("compile-linklet", 4, argc, argv, &unsafe, &static_mode); + parse_compile_options("compile-linklet", 4, argc, argv, &unsafe, &static_mode, &serializable); e = (Scheme_Object *)compile_and_or_optimize_linklet(e, NULL, name, &import_keys, get_import, - unsafe, static_mode); + unsafe, static_mode, serializable); if (import_keys) { a[0] = e; @@ -449,7 +449,7 @@ static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv) { Scheme_Object *name, *import_keys, *get_import, *a[2]; Scheme_Linklet *linklet; - int unsafe = 0, static_mode = 0; + int unsafe = 0, static_mode = 0, serializable = 1; if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_linklet_type)) scheme_wrong_contract("recompile-linklet", "linklet?", 0, argc, argv); @@ -475,10 +475,10 @@ static Scheme_Object *recompile_linklet(int argc, Scheme_Object **argv) } if (argc > 4) - parse_compile_options("recompile-linklet", 4, argc, argv, &unsafe, &static_mode); + parse_compile_options("recompile-linklet", 4, argc, argv, &unsafe, &static_mode, &serializable); linklet = compile_and_or_optimize_linklet(NULL, linklet, name, &import_keys, get_import, - unsafe, static_mode); + unsafe, static_mode, serializable); if (import_keys) { a[0] = (Scheme_Object *)linklet; @@ -1136,7 +1136,7 @@ static Scheme_Hash_Tree *update_source_names(Scheme_Hash_Tree *source_names, static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Scheme_Linklet *linklet, Scheme_Object *name, Scheme_Object **_import_keys, Scheme_Object *get_import, - int unsafe_mode, int static_mode) + int unsafe_mode, int static_mode, int serializable) { Scheme_Config *config; int enforce_const, set_undef, can_inline; @@ -1181,12 +1181,15 @@ static Scheme_Linklet *compile_and_or_optimize_linklet(Scheme_Object *form, Sche scheme_performance_record_end("compile", &perf_state); + if (serializable) + linklet->serializable = 1; + return linklet; } Scheme_Linklet *scheme_compile_and_optimize_linklet(Scheme_Object *form, Scheme_Object *name) { - return compile_and_or_optimize_linklet(form, NULL, name, NULL, NULL, 0, 1); + return compile_and_or_optimize_linklet(form, NULL, name, NULL, NULL, 0, 1, 0); } /*========================================================================*/ diff --git a/racket/src/racket/src/marshal.c b/racket/src/racket/src/marshal.c index 41ff58a577..e99d1a7ecb 100644 --- a/racket/src/racket/src/marshal.c +++ b/racket/src/racket/src/marshal.c @@ -292,8 +292,12 @@ Scheme_Object *scheme_write_linklet(Scheme_Object *obj) if (linklet->jit_ready) scheme_arg_mismatch("write", - "cannot marshal linklet that has been evaluated", + "cannot marshal linklet that has been evaluated: ", obj); + if (!linklet->serializable) + scheme_contract_error("write", + "linklet is not serializable", + NULL); l = scheme_null; @@ -405,6 +409,8 @@ Scheme_Object *scheme_read_linklet(Scheme_Object *obj, int unsafe_ok) linklet = MALLOC_ONE_TAGGED(Scheme_Linklet); linklet->so.type = scheme_linklet_type; + linklet->serializable = 1; + if (!SCHEME_PAIRP(obj)) return_NULL(); linklet->name = SCHEME_CAR(obj); if (!SCHEME_SYMBOLP(linklet->name)) return_NULL(); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index a79ae834b2..1b49e489e2 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3318,6 +3318,7 @@ struct Scheme_Linklet char jit_ready; /* true if the linklet is in has been prepared for the JIT */ char reject_eval; /* true when loaded without the root inspector, for example */ + char serializable; /* record whether the linklet was intended to be serialized */ Scheme_Hash_Table *constants; /* holds info about the linklet's body for inlining */