cs: change struct procedure representation and inlining

Avoid a global table to register structure procedures, and instead use
a wrapper procedure. At the same time, adjust schemify to more
agressively inline structure operations, which can avoid a significant
performance penalty for local structure types.

Closes #3535

.makefile

@@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
 
 # This branch name changes each time the pb boot files are updated:
-PB_BRANCH == circa-7.9.0.10-1
+PB_BRANCH == circa-7.9.0.11-1
 PB_REPO = https://github.com/racket/pb
 
 # Alternative source for Chez Scheme boot files, normally set by

Makefile

@@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
 RACKET =
 RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
-PB_BRANCH = circa-7.9.0.10-1
+PB_BRANCH = circa-7.9.0.11-1
 PB_REPO = https://github.com/racket/pb
 EXTRA_REPOS_BASE =
 CS_CROSS_SUFFIX =
@@ -307,18 +307,18 @@ maybe-fetch-pb-as-is:
 	echo done
 fetch-pb-from:
 	mkdir -p racket/src/ChezScheme/boot
-	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.9.0.10-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.10-1:remotes/origin/circa-7.9.0.10-1 ; fi
+	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-7.9.0.11-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.11-1:remotes/origin/circa-7.9.0.11-1 ; fi
-	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.10-1
+	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.11-1
 pb-fetch:
 	$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
 pb-build:
 	cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
 pb-stage:
-	cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.10-1
+	cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.11-1
-	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.10-1
+	cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.11-1
 	cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
 pb-push:
-	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.10-1
+	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.11-1
 win-cs-base:
 	IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
 	IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change only when
 ;; "racket_version.h" changes:
-(define version "7.9.0.10")
+(define version "7.9.0.11")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-test-core/tests/racket/macro.rktl

@@ -3,6 +3,10 @@
 
 (Section 'macro)
 
+(test #f struct-predicate-procedure? syntax?)
+
+(test #t struct-predicate-procedure? exn:fail:syntax?)
+
 (error-test #'(define-syntaxes () (values 1)) exn:application:arity?)
 (error-test #'(define-syntaxes () (values 1 2)) exn:application:arity?)
 (error-test #'(define-syntaxes (x) (values 1 2)) exn:application:arity?)

pkgs/racket-test-core/tests/racket/struct.rktl

@@ -671,6 +671,19 @@
 (test #f inspector-superior? (make-sibling-inspector) (current-inspector))
 (test #t inspector-superior? (current-inspector) (make-sibling-inspector (make-inspector)))
 
+;; ------------------------------------------------------------
+;; Some built-in structure procedures
+
+(test #t struct-predicate-procedure? exn?)
+(test #t struct-predicate-procedure? exn:fail?)
+(test #t struct-predicate-procedure? exn:fail:contract?)
+(test #t struct-predicate-procedure? srcloc?)
+(test #t struct-predicate-procedure? date?)
+
+(test #t struct-accessor-procedure? exn-message)
+(test #t struct-accessor-procedure? srcloc-line)
+(test #t struct-accessor-procedure? date-month)
+
 ;; ------------------------------------------------------------
 ;; Property accessor errors
 

pkgs/racket-test-core/tests/racket/thread.rktl

@@ -16,6 +16,10 @@
 (err/rt-test (thread (lambda (x) 8)) type?)
 (arity-test thread? 1 1)
 
+(test #f struct-predicate-procedure? thread?)
+(test #f struct-predicate-procedure? evt?)
+(test #f struct-type-property-predicate-procedure? evt?)
+
 ;; ----------------------------------------
 ;; Thread sets
 

racket/src/ChezScheme/csug/objects.stex

@@ -4491,10 +4491,27 @@ Determines whether \var{obj} is a wrapper procedure produced by either
 \endschemedisplay
 
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{wrapper-procedure-procedure}{\categoryprocedure}{(wrapper-procedure-data \var{w-proc})}
+\returns the procedure wrapped by the wrapper procedure \var{proc}
+\listlibraries
+\endentryheader
+
+\noindent
+\var{w-proc} must be a wrapper procedure produced by either
+\scheme{make-wrapper-procedure} or \scheme{make-arity-wrapper-procedure}.
+
+
+\schemedisplay
+(define vector3 (make-wrapper-procedure vector 8 'my-data))
+(arity-wrapper-procedure-data vector3) ; => #<procedure vector>
+\endschemedisplay
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{wrapper-procedure-data}{\categoryprocedure}{(wrapper-procedure-data \var{w-proc})}
-\returns the data store with the arity wrapper procedure \var{proc}
+\returns the data stored with the wrapper procedure \var{proc}
 \listlibraries
 \endentryheader
 

racket/src/ChezScheme/makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.53
+Version=csv9.5.3.54
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

racket/src/ChezScheme/s/cmacros.ss

@@ -1,4 +1,4 @@
-;;; Copyright 1984-2017 Cisco Systems, Inc.
+<;;; Copyright 1984-2017 Cisco Systems, Inc.
 ;;; 
 ;;; Licensed under the Apache License, Version 2.0 (the "License");
 ;;; you may not use this file except in compliance with the License.
@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x09050335)
+(define-constant scheme-version #x09050336)
 
 (define-syntax define-machine-types
   (lambda (x)

racket/src/ChezScheme/s/primdata.ss

@@ -1826,7 +1826,8 @@
   (with-profile-tracker [sig [(procedure) (ptr procedure) -> (ptr ptr ...)]] [flags])
   (with-source-path [sig [(maybe-who pathname procedure) -> (ptr ...)]] [flags])
   (wrapper-procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
-  (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags discard])
+  (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags])
+  (wrapper-procedure-procedure [sig [(ptr) -> (procedure)]] [flags true])
 )
 
 

racket/src/ChezScheme/s/prims.ss

@@ -2758,6 +2758,11 @@
                 ;; Indirect way of distinguishing from `$make-wrapper-procedure` result:
                 ($code-mutable-closure? c))))))
 
+(define-who wrapper-procedure-procedure
+  (lambda (x)
+    (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
+    ($closure-ref x 0)))
+
 (define-who set-wrapper-procedure!
   (lambda (x proc)
     (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))

racket/src/bc/include/scheme.h

@@ -2102,6 +2102,7 @@ extern Scheme_Extension_Table *scheme_extension_table;
 #define SCHEME_STRUCT_EXPTIME 0x80
 #define SCHEME_STRUCT_NO_MAKE_PREFIX 0x100
 #define SCHEME_STRUCT_NAMES_ARE_STRINGS 0x200
+#define SCHEME_STRUCT_BUILTIN 0x400
 
 /*========================================================================*/
 /*                           file descriptors                             */

racket/src/bc/src/cify-startup.rkt

@@ -78,8 +78,7 @@
 (define body
   (time
    (schemify-body (recognize-inferred-names bodys/re-uniqued) prim-knowns #hasheq() #hasheq() #hasheq()
-                  ;; for cify:
+                  'cify
-                  #t
                   ;; unsafe mode:
                   #t
                   ;; no prompts:

racket/src/bc/src/error.c

@@ -4751,7 +4751,7 @@ void scheme_init_exn(Scheme_Startup_Env *env)
 
 #define EXN_PARENT(id) exn_table[id].type
 
-#define EXN_FLAGS (SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_NO_MAKE_PREFIX)
+#define EXN_FLAGS (SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_NO_MAKE_PREFIX | SCHEME_STRUCT_BUILTIN)
 
 #define SETUP_STRUCT(id, parent, name, argc, args, props, guard) \
     { tmpo = scheme_make_struct_type_from_string(name, parent, argc, props, guard, 1); \

racket/src/bc/src/fun.c

@@ -1002,7 +1002,8 @@ int scheme_intern_prim_opt_flags(int flags)
     }
   }
 
-  scheme_signal_error("too many flag combinations");
+  scheme_log_abort("too many flag combinations");
+  abort();
 
   return 0;
 }

racket/src/bc/src/startup.inc

@@ -73,9 +73,6 @@ static const char *startup_source =
 "(qq-append)"
 "  (lambda (a_0 b_0) (begin (if (list? a_0) (append a_0 b_0) (raise-argument-error 'unquote-splicing \"list?\" a_0)))))"
 "(define-values"
-"(fixnum-for-every-system?)"
-"(lambda(v_0)(begin(if(fixnum? v_0)(if(fx>= v_0 -536870912)(fx<= v_0 536870911) #f) #f))))"
-"(define-values"
 "(bad-list$1)"
 "  (lambda (who_0 orig-l_0) (begin 'bad-list (raise-mismatch-error who_0 \"not a proper list: \" orig-l_0))))"
 "(define-values"
@@ -19912,7 +19909,7 @@ static const char *startup_source =
 "(let-values(((type_0)(read-byte/no-eof i_0)))"
 "(let-values(((tmp_0) type_0))"
 "(let-values(((index_0)"
-"(if(fixnum-for-every-system? tmp_0)"
+"(if(fixnum? tmp_0)"
 "(if(if(unsafe-fx>= tmp_0 1)"
 "(unsafe-fx< tmp_0 42)"
 " #f)"
@@ -20596,7 +20593,7 @@ static const char *startup_source =
 "(begin"
 "(let-values(((pos_0)(mcdr i_0)))"
 "(begin"
-"          (if (< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
+"          (if (fx< pos_0 (bytes-length (mcar i_0))) (void) (let-values () (read-error \"truncated stream\")))"
 "(set-mcdr! i_0(fx+ pos_0 1))"
 "(bytes-ref(mcar i_0) pos_0))))))"
 "(define-values"
@@ -20883,11 +20880,12 @@ static const char *startup_source =
 " record-mutator"
 " record-predicate"
 " struct-type-install-properties!"
-" register-struct-constructor!"
+" #%struct-constructor"
-" register-struct-predicate!"
+" #%struct-predicate"
-" register-struct-field-accessor!"
+" #%struct-field-accessor"
-" register-struct-field-mutator!"
+" #%struct-field-mutator"
 " unsafe-struct?"
+" unsafe-struct"
 " raise-binding-result-arity-error"
 " structure-type-lookup-prefab-uid"
 " struct-type-constructor-add-guards"

racket/src/bc/src/struct.c

@@ -134,6 +134,7 @@ static Scheme_Object *make_struct_proc(Scheme_Struct_Type *struct_type, char *fu
 
 static Scheme_Object *make_name(const char *pre, const char *tn, int tnl, const char *post1,
 				const char *fn, int fnl, const char *post2, int sym);
+XFORM_NONGCING static void adjust_primitive(Scheme_Object *vi, Scheme_Struct_Type *stype, int flags);
 
 static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always);
 
@@ -190,7 +191,7 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type);
 #define icons scheme_make_pair
 #define _intern scheme_intern_symbol
 
-#define BUILTIN_STRUCT_FLAGS (SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_MAKE_PREFIX)
+#define BUILTIN_STRUCT_FLAGS (SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_MAKE_PREFIX | SCHEME_STRUCT_BUILTIN)
 
 #define TYPE_NAME(base, blen, sym) make_name("struct:", base, blen, "", NULL, 0, "", sym)
 #define CSTR_NAME(base, blen, sym) make_name("", base, blen, "", NULL, 0, "", sym)
@@ -3296,15 +3297,17 @@ int scheme_struct_is_transparent(Scheme_Object *s)
 
 #define STRUCT_mPROCP(o, v)						\
   (SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) == (v)))
+#define STRUCT_PRIM_PROCP(o) ((((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE))
 
 static Scheme_Object *
 struct_setter_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v = argv[0];
   if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
-  return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
+  return (((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
-	   || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
+            || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
-           || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER))
+            || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER))
+           && !STRUCT_PRIM_PROCP(v))
 	  ? scheme_true : scheme_false);
 }
 
@@ -3313,8 +3316,9 @@ struct_getter_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v = argv[0];
   if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
-  return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)
+  return (((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER)
-           || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
+            || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
+           && !STRUCT_PRIM_PROCP(v))
 	  ? scheme_true : scheme_false);
 }
 
@@ -3323,7 +3327,8 @@ struct_pred_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v = argv[0];
   if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
-  return (STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_PRED)
+  return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_PRED)
+           && !STRUCT_PRIM_PROCP(v))
 	  ? scheme_true : scheme_false);
 }
 
@@ -3332,8 +3337,9 @@ struct_constr_p(int argc, Scheme_Object *argv[])
 {
   Scheme_Object *v = argv[0];
   if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
-  return ((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_CONSTR)
+  return (((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_CONSTR)
-           || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR))
+            || STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR))
+           && !STRUCT_PRIM_PROCP(v))
 	  ? scheme_true : scheme_false);
 }
 
@@ -4203,6 +4209,7 @@ Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
                           nm,
 			  SCHEME_CONSTR, 
 			  struct_type->num_slots);
+    adjust_primitive(vi, struct_type, flags);
     values[pos] = vi;
     pos++;
   }
@@ -4214,6 +4221,7 @@ Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
                           nm,
 			  SCHEME_PRED,
 			  0);
+    adjust_primitive(vi, struct_type, flags);
     values[pos] = vi;
     pos++;
   }
@@ -4235,6 +4243,7 @@ Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
                             nm,
 			    SCHEME_GETTER,
 			    slot_num);
+      adjust_primitive(vi, struct_type, flags);
       values[pos] = vi;
       pos++;
     }
@@ -4247,6 +4256,7 @@ Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
                             nm,
 			    SCHEME_SETTER,
 			    slot_num);
+      adjust_primitive(vi, struct_type, flags);
       values[pos] = vi;
       pos++;
     }
@@ -4280,6 +4290,20 @@ Scheme_Object **scheme_make_struct_values(Scheme_Object *type,
   return values;
 }
 
+static void adjust_primitive(Scheme_Object *vi, Scheme_Struct_Type *stype, int flags) {
+  if (flags & SCHEME_STRUCT_BUILTIN) {
+    /* Make sure the primitive flag is *not* set, because we mean
+       for these to be exposed as struct procedures */
+    ((Scheme_Closed_Primitive_Proc *)vi)->pp.flags &= ~SCHEME_PRIM_IS_PRIMITIVE;
+  } else if (scheme_starting_up) {
+    /* Set primitive flag on non-transparent so structs in startup
+       code (the expander and reader) are *not* exposed as a structure
+       procedure */
+    if (SCHEME_TRUEP(stype->inspector))
+      ((Scheme_Closed_Primitive_Proc *)vi)->pp.flags |= SCHEME_PRIM_IS_PRIMITIVE;
+  }
+}
+
 static Scheme_Object **_make_struct_names(const char *base, int blen,
 					  int fcount,
 					  Scheme_Object *field_symbols,

racket/src/cs/README.txt

@@ -462,6 +462,18 @@ configuration:
    increases load time and memory use of Racket programs by as much as
    50%.
 
+Structure Types
+---------------
+
+See the note in "../expander/README.txt" about structure types. That
+applies for all of layers. So, for example,
+
+   (struct-predicate-procedure? thread?) ; => #f
+
+Beware, however, that if schemify is not able to optimize a
+structure-type creation, then the current implementation will end up
+exposing structure procedures as such.
+
 Inlining Expectations
 ---------------------
 

racket/src/cs/compile-file.ss

@@ -2,7 +2,7 @@
 ;; Check to make we're using a build of Chez Scheme
 ;; that has all the features we need.
 (define-values (need-maj need-min need-sub need-dev)
-  (values 9 5 3 53))
+  (values 9 5 3 54))
 
 (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
   (error 'compile-file

racket/src/cs/convert.rkt

@@ -120,7 +120,16 @@
     (printf "Schemify...\n")
     (define body
       (time
-       (schemify-body bodys prim-knowns primitives #hasheq() #hasheq() #f unsafe-mode?
+       (schemify-body bodys prim-knowns primitives
+                      #hasheq()
+                      ;; map exports to #f to indicate which are exported
+                      ;; without triggering most export machinery:
+                      (for/hasheq ([ex exports])
+                        (if (pair? ex)
+                            (values (car ex) #f)
+                            (values ex #f)))
+                      'system ; target
+                      unsafe-mode?
                       #t    ; no-prompt?
                       #f))) ; explicit-unnamed?
     (printf "Lift...\n")

racket/src/cs/demo/struct.ss

@@ -97,6 +97,9 @@
 (check ((struct-type-make-constructor struct:q) 9 10) a-q)
 (check ((struct-type-make-predicate struct:q) a-q) #t)
 
+(check (struct-accessor-procedure? q-ref) #t)
+(check (struct-mutator-procedure? q-set!) #t)
+
 (check (andmap (lambda (a b)
                  (or (equal? a b)
                      (and (struct-accessor-procedure? a)

racket/src/cs/linklet.sls

@@ -530,7 +530,7 @@
          (schemify-linklet (show "linklet" c)
                            serializable?-box
                            (not (#%memq 'uninterned-literal options))
-                           (eq? format 'interpret)
+                           (if (eq? format 'interpret) 'interp 'compile) ; target
                            (|#%app| compile-allow-set!-undefined)
                            unsafe?
                            enforce-constant?

racket/src/cs/primitive/internal.ss

@@ -11,14 +11,14 @@
   [struct-type-install-properties! (known-constant)]
   [structure-type-lookup-prefab-uid (known-constant)]
   [struct-type-constructor-add-guards (known-constant)]
-  [register-struct-constructor! (known-constant)]
-  [register-struct-predicate! (known-constant)]
-  [register-struct-field-accessor! (known-constant)]
-  [register-struct-field-mutator! (known-constant)]
   [|#%call-with-values| (known-constant)]
   [unbox/check-undefined (known-constant)]
   [set-box!/check-undefined (known-constant)]
 
+  [|#%struct-constructor| (known-constant)]
+  [|#%struct-predicate| (known-constant)]
+  [|#%struct-field-accessor| (known-constant)]
+  [|#%struct-field-mutator| (known-constant)]
   [make-record-type-descriptor (known-constant)]
   [make-record-type-descriptor* (known-constant)]
   [make-record-constructor-descriptor (known-constant)]
@@ -27,6 +27,7 @@
   [record-accessor (known-constant)]
   [record-mutator (known-constant)]
   [unsafe-struct? (known-constant)]
+  [unsafe-struct (known-constant)]
 
   [call-with-module-prompt (known-procedure 2)]
   [raise-binding-result-arity-error (known-procedure 4)]

racket/src/cs/rumble.sls

@@ -221,10 +221,10 @@
           make-struct-field-accessor
           make-struct-field-mutator
           struct-type-constructor-add-guards ; not exported to Racket
-          register-struct-constructor! ; not exported to Racket
+          |#%struct-constructor| ; not exported to Racket
-          register-struct-predicate! ; not exported to Racket
+          |#%struct-predicate| ; not exported to Racket
-          register-struct-field-accessor! ; not exported to Racket
+          |#%struct-field-accessor| ; not exported to Racket
-          register-struct-field-mutator! ; not exported to Racket
+          |#%struct-field-mutator| ; not exported to Racket
           struct-property-set!  ; not exported to Racket
           struct-constructor-procedure?
           struct-predicate-procedure?
@@ -693,6 +693,7 @@
           unsafe-struct*-set!
           unsafe-struct*-cas!
           unsafe-struct? ; not exported to racket
+          unsafe-struct  ; not exported to racket
 
           unsafe-s16vector-ref
           unsafe-s16vector-set!

racket/src/cs/rumble/impersonator.ss

@@ -505,10 +505,10 @@
            [(struct-mutator-procedure? (car args))
             (let* ([orig-proc (car args)]
                    [key-proc (strip-impersonator orig-proc)]
-                   [rtd+pos (struct-mutator-procedure-rtd+pos key-proc)])
+                   [pos+rtd (struct-mutator-procedure-pos+rtd key-proc)])
               (get-proc "mutator" args 2
-                        orig-proc (car rtd+pos) (struct-mutator-pos->key2 (cdr rtd+pos))
+                        orig-proc (cdr pos+rtd) (struct-mutator-pos->key2 (car pos+rtd))
-                        (record? val (car rtd+pos))
+                        (record? val (cdr pos+rtd))
                         #t))]
            [(struct-type-property-accessor-procedure? (car args))
             (let* ([orig-proc (car args)]
@@ -548,7 +548,8 @@
             [(null? args) empty-hash]
             [(struct-mutator-procedure? (car args))
              (hash-set (loop (cddr args))
-                       (struct-mutator-procedure-rtd+pos (strip-impersonator (car args)))
+                       (let ([pos+rtd (struct-mutator-procedure-pos+rtd (strip-impersonator (car args)))])
+                         (cons (cdr pos+rtd) (car pos+rtd)))
                        #t)]
             [else
              (loop (cddr args))]))])

racket/src/cs/rumble/procedure.ss

@@ -338,6 +338,10 @@
 ;;  - (vector <symbol-or-#f> <proc> 'method) => is a method
 ;;  - (box <symbol>) => JIT function generated, name is <symbol>, not a method
 ;;  - <parameter-data> => parameter
+;;  - 'constructor => struct constructor
+;;  - 'predicate => struct predicate
+;;  - (cons rtd pos) => struct accessor
+;;  - (cons pos rtd) => struct mutator
 
 ;; ----------------------------------------
 
@@ -580,7 +584,7 @@
      [(#%vector? name) (or (#%vector-ref name 0)
                            (object-name (#%vector-ref name 1)))]
      [(parameter-data? name) (parameter-data-name name)]
-     [else name])))
+     [else (object-name (wrapper-procedure-procedure p))])))
 
 ;; ----------------------------------------
 

racket/src/cs/rumble/struct.ss

@@ -47,7 +47,7 @@
                                    (struct-type-property? (car p))
                                    (procedure? (cdr p))
                                    (procedure-arity-includes? (cdr p) 1)))
-                            supers))
+                            supers))<
        (raise-argument-error who "(listof (cons/c struct-type-property? (procedure-arity-includes/c 1)))" supers))
      (let* ([can-impersonate? (and (or can-impersonate? (eq? guard 'can-impersonate)) #t)]
             [st (make-struct-type-prop name (and (not (eq? guard 'can-impersonate)) guard) supers)]
@@ -378,6 +378,8 @@
 ;; a lock
 (define rtd-mutables (make-ephemeron-eq-hashtable))
 
+(define struct-proc-tables-need-resize? #f)
+
 ;; Accessors and mutators that need a position are wrapped in these records:
 (define-record position-based-accessor (rtd offset field-count))
 (define-record position-based-mutator (rtd offset field-count))
@@ -389,15 +391,6 @@
   (let ([rtd (position-based-mutator-rtd f)])
     (string->symbol (string-append (symbol->string (record-type-name rtd)) "-set!"))))
 
-;; Register other procedures in hash tables; avoid wrapping to
-;; avoid making the procedures slower. These tables are accessed
-;; without a lock, so son't use `hashtable-set!` on them.
-(define struct-constructors (make-ephemeron-eq-hashtable))
-(define struct-predicates (make-ephemeron-eq-hashtable))
-(define struct-field-accessors (make-ephemeron-eq-hashtable))
-(define struct-field-mutators (make-ephemeron-eq-hashtable))
-(define struct-proc-tables-need-resize? #f)
-
 (define (add-to-table! table key val)
   (if (eq-hashtable-try-atomic-cell table key val)
       (set! struct-proc-tables-need-resize? #t)
@@ -413,60 +406,60 @@
                      (let ([p (cons #f #f)])
                        (eq-hashtable-set! ht p #t)
                        (eq-hashtable-delete! ht p)))])
-      (resize! struct-constructors)
-      (resize! struct-predicates)
-      (resize! struct-field-accessors)
-      (resize! struct-field-mutators)
       (resize! property-accessors)
       (resize! property-predicates)
       (resize! rtd-mutables)
       (resize! rtd-props))))
 
-(define (register-struct-constructor! p)
+(define (|#%struct-constructor| p arity-mask)
-  (#%$app/no-inline add-to-table! struct-constructors p #t))
+  (make-wrapper-procedure p arity-mask 'constructor))
 
-(define (register-struct-predicate! p)
+(define (|#%struct-predicate| p)
-  (#%$app/no-inline add-to-table! struct-predicates p #t))
+  (make-wrapper-procedure p 2 'predicate))
 
-(define (register-struct-field-accessor! p rtd pos)
+(define (|#%struct-field-accessor| p rtd pos)
-  (#%$app/no-inline add-to-table! struct-field-accessors p (cons rtd pos)))
+  (make-wrapper-procedure p 2 (cons rtd pos)))
 
-(define (register-struct-field-mutator! p rtd pos)
+(define (|#%struct-field-mutator| p rtd pos)
-  (#%$app/no-inline add-to-table! struct-field-mutators p (cons rtd pos)))
+  (make-wrapper-procedure p 4 (cons pos rtd)))
 
 (define (struct-constructor-procedure? v)
-  (and (procedure? v)
+  (let ([v (strip-impersonator v)])
-       (let ([v (strip-impersonator v)])
+    (and (wrapper-procedure? v)
-         (eq-hashtable-contains? struct-constructors v))))
+         (eq? 'constructor (wrapper-procedure-data v)))))
 
 (define (struct-predicate-procedure? v)
-  (and (procedure? v)
+  (let ([v (strip-impersonator v)])
-       (let ([v (strip-impersonator v)])
+    (and (wrapper-procedure? v)
-         (eq-hashtable-contains? struct-predicates v))))
+         (eq? 'predicate (wrapper-procedure-data v)))))
 
 (define (struct-accessor-procedure? v)
-  (and (procedure? v)
+  (let ([v (strip-impersonator v)])
-       (let ([v (strip-impersonator v)])
+    (or (position-based-accessor? v)
-         (or (position-based-accessor? v)
+        (and (wrapper-procedure? v)
-             (eq-hashtable-contains? struct-field-accessors v)))))
+             (let ([d (wrapper-procedure-data v)])
+               (and (pair? d)
+                    (record-type-descriptor? (car d))))))))
 
 (define (struct-mutator-procedure? v)
-  (and (procedure? v)
+  (let ([v (strip-impersonator v)])
-       (let ([v (strip-impersonator v)])
+    (or (position-based-mutator? v)
-         (or (position-based-mutator? v)
+        (and (wrapper-procedure? v)
-             (eq-hashtable-contains? struct-field-mutators v)))))
+             (let ([d (wrapper-procedure-data v)])
+             <  (and (pair? d)
+                    (record-type-descriptor? (cdr d))))))))
 
 (define (struct-accessor-procedure-rtd+pos v)
   (if (position-based-accessor? v)
       (cons (position-based-accessor-rtd v)
             (position-based-accessor-offset v))
-      (eq-hashtable-ref struct-field-accessors v #f)))
+      (wrapper-procedure-data v)))
 
-(define (struct-mutator-procedure-rtd+pos v)
+(define (struct-mutator-procedure-pos+rtd v)
   (if (position-based-mutator? v)
-      (cons (position-based-mutator-rtd v)
+      (cons (position-based-mutator-offset v)
-            (position-based-mutator-offset v))
+            (position-based-mutator-rtd v))
-      (eq-hashtable-ref struct-field-mutators v #f)))
+      (wrapper-procedure-data v)))
 
 ;; ----------------------------------------
 
@@ -549,11 +542,9 @@
                           (and (impersonator? v)
                                (record? (impersonator-val v) rtd))))
                     (string->symbol (string-append (symbol->string name) "?")))])
-         (register-struct-constructor! ctr)
-         (register-struct-predicate! pred)
          (values rtd
-                 ctr
+                 (|#%struct-constructor| ctr (procedure-arity-mask ctr))
-                 pred
+                 (|#%struct-predicate| pred)
                  (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
                  (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)))))]))
 
@@ -740,8 +731,7 @@
                                                (if name
                                                    (symbol->string name)
                                                    (string-append "field" (number->string pos))))))])
-        (register-struct-field-accessor! wrap-p rtd pos)
+        (|#%struct-field-accessor| wrap-p rtd pos)))]
-        wrap-p))]
    [(pba pos)
     (make-struct-field-accessor pba pos #f)]))
 
@@ -776,8 +766,7 @@
                    (lambda (v a)
                      (cannot-modify-by-pos-error mut-name v pos)))
                mut-name)])
-        (register-struct-field-mutator! wrap-p rtd pos)
+        (|#%struct-field-mutator| wrap-p rtd pos)))]
-        wrap-p))]
    [(pbm pos)
     (make-struct-field-mutator pbm pos #f)]))
 
@@ -889,24 +878,27 @@
     (check who symbol? :or-false name)
     (let ([rtd* (strip-impersonator rtd)])
       (check-inspector-access who rtd*)
-      (let ([ctr (struct-type-constructor-add-guards
+      (let ([ctr (let* ([c (record-constructor rtd*)]
-                  (let* ([c (record-constructor rtd*)]
+                        [fi (struct-type-field-info rtd*)]
-                         [fi (struct-type-field-info rtd*)]
+                        [init*-count (get-field-info-init*-count fi)]
-                         [auto-field-adder (get-field-info-auto-adder fi)]
+                        [init*-count-mask (bitwise-arithmetic-shift-left 1 init*-count)]
-                         [name (or name
+                        [auto-field-adder (get-field-info-auto-adder fi)]
-                                   (string->symbol (format "make-~a" (record-type-name rtd*))))])
+                        [name (or name
-                    (cond
+                                  (string->symbol (format "make-~a" (record-type-name rtd*))))])
-                     [auto-field-adder
+                   (|#%struct-constructor|
-                      (procedure-rename
+                    (struct-type-constructor-add-guards
-                       (procedure-reduce-arity
+                     (cond
-                        (lambda args
+                       [auto-field-adder
-                          (apply c (reverse (auto-field-adder (reverse args)))))
+                        (procedure-rename
-                        (get-field-info-init*-count fi))
+                         (procedure-reduce-arity-mask
-                       name)]
+                          (lambda args
-                     [else (procedure-rename c name)]))
+                            (apply c (reverse (auto-field-adder (reverse args)))))
-                  rtd*
+                          init*-count-mask)
-                  #f)])
+                         name)]
-        (register-struct-constructor! ctr)
+                       [else (procedure-rename c name)])
+                     rtd*
+                     #f)
+                    init*-count-mask))])
         (cond
          [(struct-type-chaperone? rtd)
           (chaperone-constructor rtd ctr)]
@@ -958,13 +950,12 @@
   (check who struct-type? rtd)
   (let ([rtd* (strip-impersonator rtd)])
     (check-inspector-access who rtd*)
-    (let ([pred (escapes-ok
+    (|#%struct-predicate|
-                  (lambda (v)
+     (escapes-ok
-                    (or (record? v rtd*)
+      (lambda (v)
-                        (and (impersonator? v)
+        (or (record? v rtd*)
-                             (record? (impersonator-val v) rtd*)))))])
+            (and (impersonator? v)
-      (register-struct-predicate! pred)
+                 (record? (impersonator-val v) rtd*))))))))
-      pred)))
 
 ;; ----------------------------------------
 
@@ -1088,6 +1079,9 @@
 (define (unsafe-struct? v r)
   (#3%record? v r))
 
+(define (unsafe-struct r . args)
+  (#%apply #%$record r args))
+
 (define (unsafe-struct-ref s i)
   (if (impersonator? s)
       (let loop ([rtd* (record-rtd (impersonator-val s))])
@@ -1289,21 +1283,23 @@
                  (define unsafe-make-name (record-constructor (make-record-constructor-descriptor struct:name #f #f)))
                  (define name ctr-expr)
                  (define authentic-name? (record-predicate struct:name))
-                 (define name? (lambda (v) (or (authentic-name? v)
+                 (define name? (|#%struct-predicate|
-                                               (and (impersonator? v)
+                                (lambda (v) (or (authentic-name? v)
-                                                    (authentic-name? (impersonator-val v))))))
+                                                (and (impersonator? v)
+                                                     (authentic-name? (impersonator-val v)))))))
                  (define name-field
                    (let ([name-field (record-accessor struct:name field-index)])
-                     (lambda (v)
+                     (|#%struct-field-accessor|
-                       (if (authentic-name? v)
+                      (lambda (v)
-                           (name-field v)
+                        (if (authentic-name? v)
-                           (pariah (impersonate-ref name-field struct:name field-index v 'name 'field))))))
+                            (name-field v)
+                            (pariah (impersonate-ref name-field struct:name field-index v 'name 'field))))
+                      struct:name
+                      field-index)))
                  ...
                  (define dummy
                    (begin
                      (register-struct-named! struct:name)
-                     (register-struct-constructor! name)
-                     (register-struct-field-accessor! name-field struct:name field-index) ...
                      (record-type-equal-procedure struct:name default-struct-equal?)
                      (record-type-hash-procedure struct:name default-struct-hash)
                      (inspector-set! struct:name #f)))))))])))

racket/src/cs/schemified/known.scm

@@ -173,11 +173,6 @@
         (if (impersonator? v)
           (known-constant?_2598 (impersonator-val v))
           #f))))))
-(define effect_2956
-  (begin
-    (register-struct-constructor! known-constant)
-    (register-struct-predicate! known-constant?)
-    (void)))
 (define struct:known-consistent
   (make-record-type-descriptor*
    'known-consistent
@@ -229,11 +224,6 @@
         (if (impersonator? v)
           (known-consistent?_3048 (impersonator-val v))
           #f))))))
-(define effect_3117
-  (begin
-    (register-struct-constructor! known-consistent)
-    (register-struct-predicate! known-consistent?)
-    (void)))
 (define struct:known-authentic
   (make-record-type-descriptor*
    'known-authentic
@@ -285,11 +275,6 @@
         (if (impersonator? v)
           (known-authentic?_3119 (impersonator-val v))
           #f))))))
-(define effect_2588
-  (begin
-    (register-struct-constructor! known-authentic)
-    (register-struct-predicate! known-authentic?)
-    (void)))
 (define struct:known-copy
   (make-record-type-descriptor*
    'known-copy
@@ -355,12 +340,6 @@
          s
          'known-copy
          'id))))))
-(define effect_2902
-  (begin
-    (register-struct-constructor! known-copy)
-    (register-struct-predicate! known-copy?)
-    (register-struct-field-accessor! known-copy-id struct:known-copy 0)
-    (void)))
 (define struct:known-literal
   (make-record-type-descriptor*
    'known-literal
@@ -428,15 +407,6 @@
          s
          'known-literal
          'value))))))
-(define effect_2398
-  (begin
-    (register-struct-constructor! known-literal)
-    (register-struct-predicate! known-literal?)
-    (register-struct-field-accessor!
-     known-literal-value
-     struct:known-literal
-     0)
-    (void)))
 (define struct:known-procedure
   (make-record-type-descriptor*
    'known-procedure
@@ -506,15 +476,6 @@
          s
          'known-procedure
          'arity-mask))))))
-(define effect_1399
-  (begin
-    (register-struct-constructor! known-procedure)
-    (register-struct-predicate! known-procedure?)
-    (register-struct-field-accessor!
-     known-procedure-arity-mask
-     struct:known-procedure
-     0)
-    (void)))
 (define struct:known-procedure/no-prompt
   (make-record-type-descriptor*
    'known-procedure/no-prompt
@@ -571,11 +532,6 @@
         (if (impersonator? v)
           (known-procedure/no-prompt?_2036 (impersonator-val v))
           #f))))))
-(define effect_2150
-  (begin
-    (register-struct-constructor! known-procedure/no-prompt)
-    (register-struct-predicate! known-procedure/no-prompt?)
-    (void)))
 (define struct:known-procedure/can-inline
   (make-record-type-descriptor*
    'known-procedure/can-inline
@@ -650,15 +606,6 @@
          s
          'known-procedure/can-inline
          'expr))))))
-(define effect_2594
-  (begin
-    (register-struct-constructor! known-procedure/can-inline)
-    (register-struct-predicate! known-procedure/can-inline?)
-    (register-struct-field-accessor!
-     known-procedure/can-inline-expr
-     struct:known-procedure/can-inline
-     0)
-    (void)))
 (define struct:known-procedure/can-inline/need-imports
   (make-record-type-descriptor*
    'known-procedure/can-inline/need-imports
@@ -733,15 +680,6 @@
          s
          'known-procedure/can-inline/need-imports
          'needed))))))
-(define effect_2494
-  (begin
-    (register-struct-constructor! known-procedure/can-inline/need-imports)
-    (register-struct-predicate! known-procedure/can-inline/need-imports?)
-    (register-struct-field-accessor!
-     known-procedure/can-inline/need-imports-needed
-     struct:known-procedure/can-inline/need-imports
-     0)
-    (void)))
 (define struct:known-procedure/folding
   (make-record-type-descriptor*
    'known-procedure/folding
@@ -798,11 +736,6 @@
         (if (impersonator? v)
           (known-procedure/folding?_2882 (impersonator-val v))
           #f))))))
-(define effect_2446
-  (begin
-    (register-struct-constructor! known-procedure/folding)
-    (register-struct-predicate! known-procedure/folding?)
-    (void)))
 (define struct:known-procedure/folding/limited
   (make-record-type-descriptor*
    'known-procedure/folding/limited
@@ -877,15 +810,6 @@
          s
          'known-procedure/folding/limited
          'kind))))))
-(define effect_2817
-  (begin
-    (register-struct-constructor! known-procedure/folding/limited)
-    (register-struct-predicate! known-procedure/folding/limited?)
-    (register-struct-field-accessor!
-     known-procedure/folding/limited-kind
-     struct:known-procedure/folding/limited
-     0)
-    (void)))
 (define struct:known-procedure/succeeds
   (make-record-type-descriptor*
    'known-procedure/succeeds
@@ -942,11 +866,6 @@
         (if (impersonator? v)
           (known-procedure/succeeds?_3041 (impersonator-val v))
           #f))))))
-(define effect_2473
-  (begin
-    (register-struct-constructor! known-procedure/succeeds)
-    (register-struct-predicate! known-procedure/succeeds?)
-    (void)))
 (define struct:known-procedure/pure
   (make-record-type-descriptor*
    'known-procedure/pure
@@ -1000,11 +919,6 @@
         (if (impersonator? v)
           (known-procedure/pure?_2240 (impersonator-val v))
           #f))))))
-(define effect_2621
-  (begin
-    (register-struct-constructor! known-procedure/pure)
-    (register-struct-predicate! known-procedure/pure?)
-    (void)))
 (define struct:known-procedure/pure/folding
   (make-record-type-descriptor*
    'known-procedure/pure/folding
@@ -1061,11 +975,6 @@
         (if (impersonator? v)
           (known-procedure/pure/folding?_2719 (impersonator-val v))
           #f))))))
-(define effect_2449
-  (begin
-    (register-struct-constructor! known-procedure/pure/folding)
-    (register-struct-predicate! known-procedure/pure/folding?)
-    (void)))
 (define struct:known-procedure/pure/folding-unsafe
   (make-record-type-descriptor*
    'known-procedure/pure/folding-unsafe
@@ -1140,15 +1049,6 @@
          s
          'known-procedure/pure/folding-unsafe
          'safe))))))
-(define effect_2336
-  (begin
-    (register-struct-constructor! known-procedure/pure/folding-unsafe)
-    (register-struct-predicate! known-procedure/pure/folding-unsafe?)
-    (register-struct-field-accessor!
-     known-procedure/pure/folding-unsafe-safe
-     struct:known-procedure/pure/folding-unsafe
-     0)
-    (void)))
 (define struct:known-procedure/has-unsafe
   (make-record-type-descriptor*
    'known-procedure/has-unsafe
@@ -1223,15 +1123,6 @@
          s
          'known-procedure/has-unsafe
          'alternate))))))
-(define effect_1976
-  (begin
-    (register-struct-constructor! known-procedure/has-unsafe)
-    (register-struct-predicate! known-procedure/has-unsafe?)
-    (register-struct-field-accessor!
-     known-procedure/has-unsafe-alternate
-     struct:known-procedure/has-unsafe
-     0)
-    (void)))
 (define struct:known-procedure/has-unsafe/folding
   (make-record-type-descriptor*
    'known-procedure/has-unsafe/folding
@@ -1288,11 +1179,6 @@
         (if (impersonator? v)
           (known-procedure/has-unsafe/folding?_2169 (impersonator-val v))
           #f))))))
-(define effect_2832
-  (begin
-    (register-struct-constructor! known-procedure/has-unsafe/folding)
-    (register-struct-predicate! known-procedure/has-unsafe/folding?)
-    (void)))
 (define struct:known-procedure/has-unsafe/folding/limited
   (make-record-type-descriptor*
    'known-procedure/has-unsafe/folding/limited
@@ -1368,15 +1254,6 @@
          s
          'known-procedure/has-unsafe/folding/limited
          'kind))))))
-(define effect_2061
-  (begin
-    (register-struct-constructor! known-procedure/has-unsafe/folding/limited)
-    (register-struct-predicate! known-procedure/has-unsafe/folding/limited?)
-    (register-struct-field-accessor!
-     known-procedure/has-unsafe/folding/limited-kind
-     struct:known-procedure/has-unsafe/folding/limited
-     0)
-    (void)))
 (define struct:known-struct-type
   (make-record-type-descriptor*
    'known-struct-type
@@ -1482,23 +1359,6 @@
          s
          'known-struct-type
          'pure-constructor?))))))
-(define effect_2460
-  (begin
-    (register-struct-constructor! known-struct-type)
-    (register-struct-predicate! known-struct-type?)
-    (register-struct-field-accessor!
-     known-struct-type-type
-     struct:known-struct-type
-     0)
-    (register-struct-field-accessor!
-     known-struct-type-field-count
-     struct:known-struct-type
-     1)
-    (register-struct-field-accessor!
-     known-struct-type-pure-constructor?
-     struct:known-struct-type
-     2)
-    (void)))
 (define struct:known-constructor
   (make-record-type-descriptor*
    'known-constructor
@@ -1568,15 +1428,6 @@
          s
          'known-constructor
          'type))))))
-(define effect_2610
-  (begin
-    (register-struct-constructor! known-constructor)
-    (register-struct-predicate! known-constructor?)
-    (register-struct-field-accessor!
-     known-constructor-type
-     struct:known-constructor
-     0)
-    (void)))
 (define struct:known-predicate
   (make-record-type-descriptor*
    'known-predicate
@@ -1644,15 +1495,6 @@
          s
          'known-predicate
          'type))))))
-(define effect_2622
-  (begin
-    (register-struct-constructor! known-predicate)
-    (register-struct-predicate! known-predicate?)
-    (register-struct-field-accessor!
-     known-predicate-type
-     struct:known-predicate
-     0)
-    (void)))
 (define struct:known-accessor
   (make-record-type-descriptor*
    'known-accessor
@@ -1672,7 +1514,7 @@
    #f
    1
    1))
-(define effect_2151
+(define effect_2150
   (struct-type-install-properties!
    struct:known-accessor
    'known-accessor
@@ -1720,15 +1562,6 @@
          s
          'known-accessor
          'type))))))
-(define effect_3078
-  (begin
-    (register-struct-constructor! known-accessor)
-    (register-struct-predicate! known-accessor?)
-    (register-struct-field-accessor!
-     known-accessor-type
-     struct:known-accessor
-     0)
-    (void)))
 (define struct:known-mutator
   (make-record-type-descriptor*
    'known-mutator
@@ -1796,12 +1629,80 @@
          s
          'known-mutator
          'type))))))
-(define effect_2451
+(define struct:known-struct-constructor
-  (begin
+  (make-record-type-descriptor*
-    (register-struct-constructor! known-mutator)
+   'known-struct-constructor
-    (register-struct-predicate! known-mutator?)
+   (if (struct-type? struct:known-constructor)
-    (register-struct-field-accessor! known-mutator-type struct:known-mutator 0)
+     struct:known-constructor
-    (void)))
+     (check-struct-type 'struct struct:known-constructor))
+   (structure-type-lookup-prefab-uid
+    'known-struct-constructor
+    (if (struct-type? struct:known-constructor)
+      struct:known-constructor
+      (check-struct-type 'struct struct:known-constructor))
+    1
+    0
+    #f
+    '(0))
+   #f
+   #f
+   1
+   1))
+(define effect_3019
+  (struct-type-install-properties!
+   struct:known-struct-constructor
+   'known-struct-constructor
+   1
+   0
+   (if (struct-type? struct:known-constructor)
+     struct:known-constructor
+     (check-struct-type 'struct struct:known-constructor))
+   null
+   'prefab
+   #f
+   '(0)
+   #f
+   'known-struct-constructor))
+(define known-struct-constructor
+  (|#%name|
+   known-struct-constructor
+   (record-constructor
+    (make-record-constructor-descriptor
+     struct:known-struct-constructor
+     #f
+     #f))))
+(define known-struct-constructor?_2705
+  (|#%name|
+   known-struct-constructor?
+   (record-predicate struct:known-struct-constructor)))
+(define known-struct-constructor?
+  (|#%name|
+   known-struct-constructor?
+   (lambda (v)
+     (if (known-struct-constructor?_2705 v)
+       #t
+       ($value
+        (if (impersonator? v)
+          (known-struct-constructor?_2705 (impersonator-val v))
+          #f))))))
+(define known-struct-constructor-type-id_2882
+  (|#%name|
+   known-struct-constructor-type-id
+   (record-accessor struct:known-struct-constructor 0)))
+(define known-struct-constructor-type-id
+  (|#%name|
+   known-struct-constructor-type-id
+   (lambda (s)
+     (if (known-struct-constructor?_2705 s)
+       (known-struct-constructor-type-id_2882 s)
+       ($value
+        (impersonate-ref
+         known-struct-constructor-type-id_2882
+         struct:known-struct-constructor
+         0
+         s
+         'known-struct-constructor
+         'type-id))))))
 (define struct:known-struct-predicate
   (make-record-type-descriptor*
    'known-struct-predicate
@@ -1891,19 +1792,6 @@
          s
          'known-struct-predicate
          'authentic?))))))
-(define effect_2415
-  (begin
-    (register-struct-constructor! known-struct-predicate)
-    (register-struct-predicate! known-struct-predicate?)
-    (register-struct-field-accessor!
-     known-struct-predicate-type-id
-     struct:known-struct-predicate
-     0)
-    (register-struct-field-accessor!
-     known-struct-predicate-authentic?
-     struct:known-struct-predicate
-     1)
-    (void)))
 (define struct:known-field-accessor
   (make-record-type-descriptor*
    'known-field-accessor
@@ -1993,19 +1881,6 @@
          s
          'known-field-accessor
          'pos))))))
-(define effect_2652
-  (begin
-    (register-struct-constructor! known-field-accessor)
-    (register-struct-predicate! known-field-accessor?)
-    (register-struct-field-accessor!
-     known-field-accessor-type-id
-     struct:known-field-accessor
-     0)
-    (register-struct-field-accessor!
-     known-field-accessor-pos
-     struct:known-field-accessor
-     1)
-    (void)))
 (define struct:known-field-mutator
   (make-record-type-descriptor*
    'known-field-mutator
@@ -2095,19 +1970,80 @@
          s
          'known-field-mutator
          'pos))))))
-(define effect_2676
+(define struct:known-struct-constructor/need-imports
-  (begin
+  (make-record-type-descriptor*
-    (register-struct-constructor! known-field-mutator)
+   'known-struct-constructor/need-imports
-    (register-struct-predicate! known-field-mutator?)
+   (if (struct-type? struct:known-struct-constructor)
-    (register-struct-field-accessor!
+     struct:known-struct-constructor
-     known-field-mutator-type-id
+     (check-struct-type 'struct struct:known-struct-constructor))
-     struct:known-field-mutator
+   (structure-type-lookup-prefab-uid
-     0)
+    'known-struct-constructor/need-imports
-    (register-struct-field-accessor!
+    (if (struct-type? struct:known-struct-constructor)
-     known-field-mutator-pos
+      struct:known-struct-constructor
-     struct:known-field-mutator
+      (check-struct-type 'struct struct:known-struct-constructor))
-     1)
+    1
-    (void)))
+    0
+    #f
+    '(0))
+   #f
+   #f
+   1
+   1))
+(define effect_2765
+  (struct-type-install-properties!
+   struct:known-struct-constructor/need-imports
+   'known-struct-constructor/need-imports
+   1
+   0
+   (if (struct-type? struct:known-struct-constructor)
+     struct:known-struct-constructor
+     (check-struct-type 'struct struct:known-struct-constructor))
+   null
+   'prefab
+   #f
+   '(0)
+   #f
+   'known-struct-constructor/need-imports))
+(define known-struct-constructor/need-imports
+  (|#%name|
+   known-struct-constructor/need-imports
+   (record-constructor
+    (make-record-constructor-descriptor
+     struct:known-struct-constructor/need-imports
+     #f
+     #f))))
+(define known-struct-constructor/need-imports?_2300
+  (|#%name|
+   known-struct-constructor/need-imports?
+   (record-predicate struct:known-struct-constructor/need-imports)))
+(define known-struct-constructor/need-imports?
+  (|#%name|
+   known-struct-constructor/need-imports?
+   (lambda (v)
+     (if (known-struct-constructor/need-imports?_2300 v)
+       #t
+       ($value
+        (if (impersonator? v)
+          (known-struct-constructor/need-imports?_2300 (impersonator-val v))
+          #f))))))
+(define known-struct-constructor/need-imports-needed_2757
+  (|#%name|
+   known-struct-constructor/need-imports-needed
+   (record-accessor struct:known-struct-constructor/need-imports 0)))
+(define known-struct-constructor/need-imports-needed
+  (|#%name|
+   known-struct-constructor/need-imports-needed
+   (lambda (s)
+     (if (known-struct-constructor/need-imports?_2300 s)
+       (known-struct-constructor/need-imports-needed_2757 s)
+       ($value
+        (impersonate-ref
+         known-struct-constructor/need-imports-needed_2757
+         struct:known-struct-constructor/need-imports
+         0
+         s
+         'known-struct-constructor/need-imports
+         'needed))))))
 (define struct:known-struct-predicate/need-imports
   (make-record-type-descriptor*
    'known-struct-predicate/need-imports
@@ -2182,15 +2118,6 @@
          s
          'known-struct-predicate/need-imports
          'needed))))))
-(define effect_1651
-  (begin
-    (register-struct-constructor! known-struct-predicate/need-imports)
-    (register-struct-predicate! known-struct-predicate/need-imports?)
-    (register-struct-field-accessor!
-     known-struct-predicate/need-imports-needed
-     struct:known-struct-predicate/need-imports
-     0)
-    (void)))
 (define struct:known-field-accessor/need-imports
   (make-record-type-descriptor*
    'known-field-accessor/need-imports
@@ -2265,15 +2192,6 @@
          s
          'known-field-accessor/need-imports
          'needed))))))
-(define effect_2889
-  (begin
-    (register-struct-constructor! known-field-accessor/need-imports)
-    (register-struct-predicate! known-field-accessor/need-imports?)
-    (register-struct-field-accessor!
-     known-field-accessor/need-imports-needed
-     struct:known-field-accessor/need-imports
-     0)
-    (void)))
 (define struct:known-field-mutator/need-imports
   (make-record-type-descriptor*
    'known-field-mutator/need-imports
@@ -2348,15 +2266,6 @@
          s
          'known-field-mutator/need-imports
          'needed))))))
-(define effect_2411
-  (begin
-    (register-struct-constructor! known-field-mutator/need-imports)
-    (register-struct-predicate! known-field-mutator/need-imports?)
-    (register-struct-field-accessor!
-     known-field-mutator/need-imports-needed
-     struct:known-field-mutator/need-imports
-     0)
-    (void)))
 (define struct:known-struct-type-property/immediate-guard
   (make-record-type-descriptor*
    'known-struct-type-property/immediate-guard
@@ -2408,10 +2317,5 @@
           (known-struct-type-property/immediate-guard?_2536
            (impersonator-val v))
           #f))))))
-(define effect_1742
-  (begin
-    (register-struct-constructor! known-struct-type-property/immediate-guard)
-    (register-struct-predicate! known-struct-type-property/immediate-guard?)
-    (void)))
 (define a-known-constant (known-constant))
 (define a-known-consistent (known-consistent))

racket/src/cs/schemified/regexp.scm

@@ -886,13 +886,6 @@
        (rx:alts-rx_2917 s)
        ($value
         (impersonate-ref rx:alts-rx_2917 struct:rx:alts 1 s 'rx:alts 'rx2))))))
-(define effect_2536
-  (begin
-    (register-struct-constructor! rx:alts1.1)
-    (register-struct-predicate! rx:alts?)
-    (register-struct-field-accessor! rx:alts-rx_1874 struct:rx:alts 0)
-    (register-struct-field-accessor! rx:alts-rx_2761 struct:rx:alts 1)
-    (void)))
 (define struct:rx:sequence
   (make-record-type-descriptor* 'rx:sequence #f #f #f #f 2 0))
 (define effect_2137
@@ -957,16 +950,6 @@
          s
          'rx:sequence
          'needs-backtrack?))))))
-(define effect_2844
-  (begin
-    (register-struct-constructor! rx:sequence2.1)
-    (register-struct-predicate! rx:sequence?)
-    (register-struct-field-accessor! rx:sequence-rxs struct:rx:sequence 0)
-    (register-struct-field-accessor!
-     rx:sequence-needs-backtrack?
-     struct:rx:sequence
-     1)
-    (void)))
 (define struct:rx:group
   (make-record-type-descriptor* 'rx:group #f #f #f #f 2 0))
 (define effect_2340
@@ -1028,13 +1011,6 @@
          s
          'rx:group
          'number))))))
-(define effect_2814
-  (begin
-    (register-struct-constructor! rx:group3.1)
-    (register-struct-predicate! rx:group?)
-    (register-struct-field-accessor! rx:group-rx struct:rx:group 0)
-    (register-struct-field-accessor! rx:group-number struct:rx:group 1)
-    (void)))
 (define struct:rx:repeat
   (make-record-type-descriptor* 'rx:repeat #f #f #f #f 4 0))
 (define effect_2551
@@ -1129,15 +1105,6 @@
          s
          'rx:repeat
          'non-greedy?))))))
-(define effect_2847
-  (begin
-    (register-struct-constructor! rx:repeat4.1)
-    (register-struct-predicate! rx:repeat?)
-    (register-struct-field-accessor! rx:repeat-rx struct:rx:repeat 0)
-    (register-struct-field-accessor! rx:repeat-min struct:rx:repeat 1)
-    (register-struct-field-accessor! rx:repeat-max struct:rx:repeat 2)
-    (register-struct-field-accessor! rx:repeat-non-greedy? struct:rx:repeat 3)
-    (void)))
 (define struct:rx:maybe
   (make-record-type-descriptor* 'rx:maybe #f #f #f #f 2 0))
 (define effect_2619
@@ -1199,13 +1166,6 @@
          s
          'rx:maybe
          'non-greedy?))))))
-(define effect_2791
-  (begin
-    (register-struct-constructor! rx:maybe5.1)
-    (register-struct-predicate! rx:maybe?)
-    (register-struct-field-accessor! rx:maybe-rx struct:rx:maybe 0)
-    (register-struct-field-accessor! rx:maybe-non-greedy? struct:rx:maybe 1)
-    (void)))
 (define struct:rx:conditional
   (make-record-type-descriptor* 'rx:conditional #f #f #f #f 6 0))
 (define effect_2459
@@ -1336,35 +1296,6 @@
          s
          'rx:conditional
          'needs-backtrack?))))))
-(define effect_2522
-  (begin
-    (register-struct-constructor! rx:conditional6.1)
-    (register-struct-predicate! rx:conditional?)
-    (register-struct-field-accessor!
-     rx:conditional-tst
-     struct:rx:conditional
-     0)
-    (register-struct-field-accessor!
-     rx:conditional-rx_2013
-     struct:rx:conditional
-     1)
-    (register-struct-field-accessor!
-     rx:conditional-rx_2094
-     struct:rx:conditional
-     2)
-    (register-struct-field-accessor!
-     rx:conditional-n-start
-     struct:rx:conditional
-     3)
-    (register-struct-field-accessor!
-     rx:conditional-num-n
-     struct:rx:conditional
-     4)
-    (register-struct-field-accessor!
-     rx:conditional-needs-backtrack?
-     struct:rx:conditional
-     5)
-    (void)))
 (define struct:rx:lookahead
   (make-record-type-descriptor* 'rx:lookahead #f #f #f #f 4 0))
 (define effect_2324
@@ -1461,18 +1392,6 @@
          s
          'rx:lookahead
          'num-n))))))
-(define effect_2423
-  (begin
-    (register-struct-constructor! rx:lookahead7.1)
-    (register-struct-predicate! rx:lookahead?)
-    (register-struct-field-accessor! rx:lookahead-rx struct:rx:lookahead 0)
-    (register-struct-field-accessor! rx:lookahead-match? struct:rx:lookahead 1)
-    (register-struct-field-accessor!
-     rx:lookahead-n-start
-     struct:rx:lookahead
-     2)
-    (register-struct-field-accessor! rx:lookahead-num-n struct:rx:lookahead 3)
-    (void)))
 (define struct:rx:lookbehind
   (make-record-type-descriptor* 'rx:lookbehind #f #f #f #f 6 12))
 (define effect_2263
@@ -1637,40 +1556,6 @@
          v
          'rx:lookbehind
          'lb-max))))))
-(define effect_2163
-  (begin
-    (register-struct-constructor! rx:lookbehind8.1)
-    (register-struct-predicate! rx:lookbehind?)
-    (register-struct-field-accessor! rx:lookbehind-rx struct:rx:lookbehind 0)
-    (register-struct-field-accessor!
-     rx:lookbehind-match?
-     struct:rx:lookbehind
-     1)
-    (register-struct-field-accessor!
-     rx:lookbehind-lb-min
-     struct:rx:lookbehind
-     2)
-    (register-struct-field-accessor!
-     rx:lookbehind-lb-max
-     struct:rx:lookbehind
-     3)
-    (register-struct-field-accessor!
-     rx:lookbehind-n-start
-     struct:rx:lookbehind
-     4)
-    (register-struct-field-accessor!
-     rx:lookbehind-num-n
-     struct:rx:lookbehind
-     5)
-    (register-struct-field-mutator!
-     set-rx:lookbehind-lb-min!
-     struct:rx:lookbehind
-     2)
-    (register-struct-field-mutator!
-     set-rx:lookbehind-lb-max!
-     struct:rx:lookbehind
-     3)
-    (void)))
 (define struct:rx:cut (make-record-type-descriptor* 'rx:cut #f #f #f #f 4 0))
 (define effect_2942
   (struct-type-install-properties!
@@ -1756,15 +1641,6 @@
          s
          'rx:cut
          'needs-backtrack?))))))
-(define effect_2360
-  (begin
-    (register-struct-constructor! rx:cut9.1)
-    (register-struct-predicate! rx:cut?)
-    (register-struct-field-accessor! rx:cut-rx struct:rx:cut 0)
-    (register-struct-field-accessor! rx:cut-n-start struct:rx:cut 1)
-    (register-struct-field-accessor! rx:cut-num-n struct:rx:cut 2)
-    (register-struct-field-accessor! rx:cut-needs-backtrack? struct:rx:cut 3)
-    (void)))
 (define struct:rx:reference
   (make-record-type-descriptor* 'rx:reference #f #f #f #f 2 0))
 (define effect_2344
@@ -1831,16 +1707,6 @@
          s
          'rx:reference
          'case-sensitive?))))))
-(define effect_2703
-  (begin
-    (register-struct-constructor! rx:reference10.1)
-    (register-struct-predicate! rx:reference?)
-    (register-struct-field-accessor! rx:reference-n struct:rx:reference 0)
-    (register-struct-field-accessor!
-     rx:reference-case-sensitive?
-     struct:rx:reference
-     1)
-    (void)))
 (define struct:rx:range
   (make-record-type-descriptor* 'rx:range #f #f #f #f 1 0))
 (define effect_2702
@@ -1886,12 +1752,6 @@
          s
          'rx:range
          'range))))))
-(define effect_2869
-  (begin
-    (register-struct-constructor! rx:range11.1)
-    (register-struct-predicate! rx:range?)
-    (register-struct-field-accessor! rx:range-range struct:rx:range 0)
-    (void)))
 (define struct:rx:unicode-categories
   (make-record-type-descriptor* 'rx:unicode-categories #f #f #f #f 2 0))
 (define effect_2129
@@ -1962,19 +1822,6 @@
          s
          'rx:unicode-categories
          'match?))))))
-(define effect_2012
-  (begin
-    (register-struct-constructor! rx:unicode-categories12.1)
-    (register-struct-predicate! rx:unicode-categories?)
-    (register-struct-field-accessor!
-     rx:unicode-categories-symlist
-     struct:rx:unicode-categories
-     0)
-    (register-struct-field-accessor!
-     rx:unicode-categories-match?
-     struct:rx:unicode-categories
-     1)
-    (void)))
 (define needs-backtrack?
   (lambda (rx_0)
     (if (rx:alts? rx_0)
@@ -2328,33 +2175,6 @@
          s
          'parse-config
          'error-handler?))))))
-(define effect_2865
-  (begin
-    (register-struct-constructor! parse-config1.1)
-    (register-struct-predicate! parse-config?)
-    (register-struct-field-accessor! parse-config-who struct:parse-config 0)
-    (register-struct-field-accessor! parse-config-px? struct:parse-config 1)
-    (register-struct-field-accessor!
-     parse-config-case-sensitive?
-     struct:parse-config
-     2)
-    (register-struct-field-accessor!
-     parse-config-multi-line?
-     struct:parse-config
-     3)
-    (register-struct-field-accessor!
-     parse-config-group-number-box
-     struct:parse-config
-     4)
-    (register-struct-field-accessor!
-     parse-config-references?-box
-     struct:parse-config
-     5)
-    (register-struct-field-accessor!
-     parse-config-error-handler?
-     struct:parse-config
-     6)
-    (void)))
 (define make-parse-config.1
   (|#%name|
    make-parse-config
@@ -5144,46 +4964,6 @@
          v
          'lazy-bytes
          'discarded-count))))))
-(define effect_3099
-  (begin
-    (register-struct-constructor! lazy-bytes1.1)
-    (register-struct-predicate! lazy-bytes?)
-    (register-struct-field-accessor! lazy-bytes-bstr struct:lazy-bytes 0)
-    (register-struct-field-accessor! lazy-bytes-end struct:lazy-bytes 1)
-    (register-struct-field-accessor! lazy-bytes-in struct:lazy-bytes 2)
-    (register-struct-field-accessor! lazy-bytes-skip-amt struct:lazy-bytes 3)
-    (register-struct-field-accessor! lazy-bytes-prefix-len struct:lazy-bytes 4)
-    (register-struct-field-accessor! lazy-bytes-peek? struct:lazy-bytes 5)
-    (register-struct-field-accessor!
-     lazy-bytes-immediate-only?
-     struct:lazy-bytes
-     6)
-    (register-struct-field-accessor!
-     lazy-bytes-progress-evt
-     struct:lazy-bytes
-     7)
-    (register-struct-field-accessor! lazy-bytes-out struct:lazy-bytes 8)
-    (register-struct-field-accessor!
-     lazy-bytes-max-lookbehind
-     struct:lazy-bytes
-     9)
-    (register-struct-field-accessor! lazy-bytes-failed? struct:lazy-bytes 10)
-    (register-struct-field-accessor!
-     lazy-bytes-discarded-count
-     struct:lazy-bytes
-     11)
-    (register-struct-field-accessor! lazy-bytes-max-peek struct:lazy-bytes 12)
-    (register-struct-field-mutator! set-lazy-bytes-bstr! struct:lazy-bytes 0)
-    (register-struct-field-mutator! set-lazy-bytes-end! struct:lazy-bytes 1)
-    (register-struct-field-mutator!
-     set-lazy-bytes-failed?!
-     struct:lazy-bytes
-     10)
-    (register-struct-field-mutator!
-     set-lazy-bytes-discarded-count!
-     struct:lazy-bytes
-     11)
-    (void)))
 (define make-lazy-bytes
   (lambda (in_0
            skip-amt_0
@@ -7690,24 +7470,6 @@
          s
          'regexp
          'start-range))))))
-(define effect_3291
-  (begin
-    (register-struct-constructor! rx:regexp1.1)
-    (register-struct-predicate! rx:regexp?)
-    (register-struct-field-accessor! rx:regexp-bytes? struct:rx:regexp 0)
-    (register-struct-field-accessor! rx:regexp-px? struct:rx:regexp 1)
-    (register-struct-field-accessor! rx:regexp-source struct:rx:regexp 2)
-    (register-struct-field-accessor! rx:regexp-matcher struct:rx:regexp 3)
-    (register-struct-field-accessor! rx:regexp-num-groups struct:rx:regexp 4)
-    (register-struct-field-accessor! rx:regexp-references? struct:rx:regexp 5)
-    (register-struct-field-accessor!
-     rx:regexp-max-lookbehind
-     struct:rx:regexp
-     6)
-    (register-struct-field-accessor! rx:regexp-anchored? struct:rx:regexp 7)
-    (register-struct-field-accessor! rx:regexp-must-string struct:rx:regexp 8)
-    (register-struct-field-accessor! rx:regexp-start-range struct:rx:regexp 9)
-    (void)))
 (define make-regexp
   (lambda (who_0 orig-p_0 px?_0 as-bytes?_0 handler_0)
     (call-with-continuation-prompt

racket/src/expander/README.txt

@@ -226,6 +226,25 @@ reported by the expander.
 
 ----------------------------------------
 
+About structures:
+
+Constructors, predicates, accessors, etc., for a non-transparent
+structure type are defined in the implementation of the expander are
+compiled/loaded in a way that makes them claim not to be structure
+procedures when built into Racket. For example,
+
+   (struct-predicate-procedure? syntax?) ; => #f
+
+If a structure type's representation is exported, such as
+`exn:fail:syntax`, then operations do claim to be strcuture operations
+
+   (struct-predicate-procedure? exn:fail:syntax?) ; => #t
+
+As a consequence, it's ok to directly expose predicates, accessors,
+etc., without exposing an implementation detail.
+
+----------------------------------------
+
 Implementation guidelines:
 
  * Do not rely on more than `racket/base` for code that will be

racket/src/expander/compile/built-in-symbol.rkt

@@ -84,11 +84,12 @@
                record-mutator
                record-predicate
                struct-type-install-properties!
-               register-struct-constructor!
+               #%struct-constructor
-               register-struct-predicate!
+               #%struct-predicate
-               register-struct-field-accessor!
+               #%struct-field-accessor
-               register-struct-field-mutator!
+               #%struct-field-mutator
                unsafe-struct?
+               unsafe-struct
                raise-binding-result-arity-error
                structure-type-lookup-prefab-uid
                struct-type-constructor-add-guards

racket/src/schemify/aim.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+(provide aim?)
+
+;; macro statically ensures that the second argument is a valid target
+(define-syntax aim?
+  (syntax-rules (cify interp)
+    [(_ e 'cify) (eq? e 'cify)]
+    [(_ e 'interp) (eq? e 'interp)]
+    [(_ e 'system) (eq? e 'system)]))

racket/src/schemify/find-definition.rkt

@@ -11,7 +11,7 @@
 
 ;; Record top-level functions and structure types, and returns
 ;;  (values knowns struct-type-info-or-#f)
-(define (find-definitions v prim-knowns knowns imports mutated simples unsafe-mode? for-cify?
+(define (find-definitions v prim-knowns knowns imports mutated simples unsafe-mode? target
                           #:primitives [primitives #hasheq()] ; for `optimize?` mode
                           #:optimize? optimize?)
   (match v
@@ -20,7 +20,7 @@
                      (optimize orig-rhs prim-knowns primitives knowns imports mutated)
                      orig-rhs))
      (values
-      (let ([k (infer-known rhs v id knowns prim-knowns imports mutated simples unsafe-mode? for-cify?
+      (let ([k (infer-known rhs v id knowns prim-knowns imports mutated simples unsafe-mode? target
                             #:primitives primitives
                             #:optimize-inline? optimize?)])
         (if k
@@ -43,7 +43,7 @@
        (let* ([knowns (hash-set knowns
                                 (unwrap make-s)
                                 (if (struct-type-info-pure-constructor? info)
-                                    (known-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type)
+                                    (known-struct-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type struct:s)
                                     a-known-constant))]
               [knowns (hash-set knowns
                                 (unwrap s?)
@@ -120,7 +120,7 @@
                                            [rhs (in-list rhss)])
                 (define-values (new-knowns info)
                   (find-definitions `(define-values (,id) ,rhs)
-                                    prim-knowns knowns imports mutated simples unsafe-mode? for-cify?
+                                    prim-knowns knowns imports mutated simples unsafe-mode? target
                                     #:optimize? optimize?))
                 new-knowns)
               #f)]

racket/src/schemify/infer-known.rkt

@@ -9,7 +9,8 @@
          "literal.rkt"
          "inline.rkt"
          "mutated-state.rkt"
-         "optimize.rkt")
+         "optimize.rkt"
+         "aim.rkt")
 
 (provide infer-known
          can-improve-infer-known?
@@ -18,7 +19,7 @@
 ;; For definitions, it's useful to infer `a-known-constant` to reflect
 ;; that the variable will get a value without referencing anything
 ;; too early. If `post-schemify?`, then `rhs` has been schemified.
-(define (infer-known rhs defn id knowns prim-knowns imports mutated simples unsafe-mode? for-cify?
+(define (infer-known rhs defn id knowns prim-knowns imports mutated simples unsafe-mode? target
                      #:primitives [primitives #hasheq()] ; for `optimize-inline?` mode
                      #:optimize-inline? [optimize-inline? #f]
                      #:post-schemify? [post-schemify? #f])
@@ -34,7 +35,7 @@
            (let ([lam (if optimize-inline?
                           (optimize* lam prim-knowns primitives knowns imports mutated unsafe-mode?)
                           lam)])
-             (known-procedure/can-inline arity-mask (if (and unsafe-mode? (not for-cify?))
+             (known-procedure/can-inline arity-mask (if (and unsafe-mode? (not (aim? target 'cify)))
                                                         (add-begin-unsafe lam)
                                                         lam)))
            (known-procedure arity-mask))]
@@ -65,7 +66,11 @@
                  [(or (not defn)
                       ;; can't just return `known`; like `known-procedure/can-inline/need-imports`,
                       ;; we'd lose track of the need to potentially propagate imports
-                      (known-copy? known))
+                      (known-copy? known)
+                      (known-struct-constructor/need-imports? known)
+                      (known-struct-predicate/need-imports? known)
+                      (known-field-accessor/need-imports? known)
+                      (known-field-mutator/need-imports? known))
                   (known-copy rhs)]
                  [else known]))]
          [defn a-known-constant]

racket/src/schemify/inline.rkt

@@ -88,6 +88,8 @@
 
 (define (inline-type-id k im add-import! mutated imports)
   (define type-id (cond
+                    [(known-struct-constructor? k)
+                     (known-struct-constructor-type-id k)]
                     [(known-struct-predicate? k)
                      (known-struct-predicate-type-id k)]
                     [(known-field-accessor? k)
@@ -101,6 +103,10 @@
     (cond
       [(not type-id) #f]
       [(not im) '()]
+      [(known-struct-constructor/need-imports? k)
+       (needed->env (known-struct-constructor/need-imports-needed k)
+                    add-import!
+                    im)]
       [(known-struct-predicate/need-imports? k)
        (needed->env (known-struct-predicate/need-imports-needed k)
                     add-import!
@@ -241,6 +247,17 @@
          (known-procedure-arity-mask k)
          (if serializable? (wrap-truncate-paths expr) expr)
          (needed->list needed))])]
+    [(known-struct-constructor? k)
+     (define needed (needed-imports (known-struct-constructor-type-id k) prim-knowns imports exports '() '#hasheq()))
+     (cond
+       [needed
+        (known-struct-constructor/need-imports (known-procedure-arity-mask k)
+                                               (known-constructor-type k)
+                                               (known-struct-constructor-type-id k)
+                                               (needed->list needed))]
+       [else
+        (known-constructor (known-procedure-arity-mask k)
+                           (known-constructor-type k))])]
     [(known-struct-predicate? k)
      (define needed (needed-imports (known-struct-predicate-type-id k) prim-knowns imports exports '() '#hasheq()))
      (cond

racket/src/schemify/known.rkt

@@ -30,9 +30,11 @@
          known-predicate known-predicate? known-predicate-type
          known-accessor known-accessor? known-accessor-type
          known-mutator known-mutator? known-mutator-type
+         known-struct-constructor known-struct-constructor? known-struct-constructor-type-id
          known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic?
          known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-pos
          known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-pos
+         known-struct-constructor/need-imports known-struct-constructor/need-imports? known-struct-constructor/need-imports-needed
          known-struct-predicate/need-imports known-struct-predicate/need-imports? known-struct-predicate/need-imports-needed
          known-field-accessor/need-imports known-field-accessor/need-imports? known-field-accessor/need-imports-needed
          known-field-mutator/need-imports known-field-mutator/need-imports? known-field-mutator/need-imports-needed
@@ -102,9 +104,11 @@
 (struct known-predicate (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/pure)
 (struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
 (struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure)
+(struct known-struct-constructor (type-id) #:prefab #:omit-define-syntaxes #:super struct:known-constructor)
 (struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
 (struct known-field-accessor (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
 (struct known-field-mutator (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
+(struct known-struct-constructor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-constructor)
 (struct known-struct-predicate/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-predicate)
 (struct known-field-accessor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-accessor)
 (struct known-field-mutator/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-mutator)

racket/src/schemify/left-to-right.rkt

@@ -2,7 +2,8 @@
 (require "wrap.rkt"
          "match.rkt"
          "simple.rkt"
-         "gensym.rkt")
+         "gensym.rkt"
+         "aim.rkt")
 
 (provide left-to-right/let
          left-to-right/let-values
@@ -47,13 +48,13 @@
 
 ;; Convert a `let-values` to nested `let-values`es to
 ;; enforce order
-(define (left-to-right/let-values idss rhss bodys mutated for-cify?)
+(define (left-to-right/let-values idss rhss bodys mutated target)
   (cond
     [(null? (cdr idss))
      (define e (if (null? (cdr bodys))
                    (car bodys)
                    `(begin . ,bodys)))
-     (make-let-values (car idss) (car rhss) e for-cify?)]
+     (make-let-values (car idss) (car rhss) e target)]
    [else
     (let loop ([idss idss] [rhss rhss] [binds null])
       (cond
@@ -62,7 +63,7 @@
          (car idss) (car rhss)
          `(let ,binds
             . ,bodys)
-         for-cify?)]
+         target)]
        [else
         (define ids (car idss))
         (make-let-values
@@ -71,14 +72,14 @@
          (loop (cdr idss) (cdr rhss) (append (for/list ([id (in-wrap-list ids)])
                                                `[,id ,id])
                                              binds))
-         for-cify?)]))]))
+         target)]))]))
 
 ;; Convert an application to enforce left-to-right
 ;; evaluation order
-(define (left-to-right/app rator rands plain-app? for-cify?
+(define (left-to-right/app rator rands plain-app? target
                            prim-knowns knowns imports mutated simples)
   (cond
-    [for-cify? (cons rator rands)]
+    [(aim? target 'cify) (cons rator rands)]
     [else
      (let loop ([l (cons rator rands)] [accum null] [pending-non-simple #f] [pending-id #f])
        (cond
@@ -110,7 +111,7 @@
 
 ;; ----------------------------------------
 
-(define (make-let-values ids rhs body for-cify?)
+(define (make-let-values ids rhs body target)
   (cond
    [(and (pair? ids) (null? (cdr ids)))
     `(let ([,(car ids) ,rhs]) ,body)]
@@ -120,7 +121,7 @@
        `(begin ,rhs ,body)]
       [`,_
        (cond
-         [for-cify?
+         [(aim? target 'cify)
           ;; No checking
           `(call-with-values (lambda () ,rhs)
              (lambda ,ids ,body))]

racket/src/schemify/letrec.rkt

@@ -2,7 +2,8 @@
 (require "wrap.rkt"
          "match.rkt"
          "infer-known.rkt"
-         "mutated-state.rkt")
+         "mutated-state.rkt"
+         "aim.rkt")
 
 (provide letrec-splitable-values-binding?
          letrec-split-values-binding
@@ -27,9 +28,9 @@
                      `[(,id) ,rhs])
      . ,bodys))
 
-(define (letrec-conversion ids mutated for-cify? e)
+(define (letrec-conversion ids mutated target e)
   (define need-convert?
-    (and (not for-cify?)
+    (and (not (aim? target 'cify))
          (let loop ([ids ids])
            (cond
              [(symbol? ids)

racket/src/schemify/mutated.rkt

@@ -24,7 +24,7 @@
 ;; This pass is also responsible for recording when a letrec binding
 ;; must be mutated implicitly via `call/cc`.
 
-(define (mutated-in-body l exports prim-knowns knowns imports simples unsafe-mode? for-cify? enforce-constant?)
+(define (mutated-in-body l exports prim-knowns knowns imports simples unsafe-mode? target enforce-constant?)
   ;; Find all `set!`ed variables, and also record all bindings
   ;; that might be used too early
   (define mutated (make-hasheq))
@@ -53,7 +53,7 @@
     ;; that information is correct, because it dynamically precedes
     ;; the `set!`
     (define-values (knowns info)
-      (find-definitions form prim-knowns prev-knowns imports mutated simples unsafe-mode? for-cify?
+      (find-definitions form prim-knowns prev-knowns imports mutated simples unsafe-mode? target
                         #:optimize? #f))
     (match form
       [`(define-values (,ids ...) ,rhs)

racket/src/schemify/schemify.rkt

@@ -24,7 +24,8 @@
          "literal.rkt"
          "authentic.rkt"
          "single-valued.rkt"
-         "gensym.rkt")
+         "gensym.rkt"
+         "aim.rkt")
 
 (provide schemify-linklet
          schemify-body)
@@ -78,7 +79,7 @@
 ;; means that a variable (which boxes a value) is expected.
 ;; If `serializable?-box` is not #f, it is filled with a
 ;; hash table of objects that need to be handled by `racket/fasl`.
-(define (schemify-linklet lk serializable?-box datum-intern? for-interp? allow-set!-undefined?
+(define (schemify-linklet lk serializable?-box datum-intern? target allow-set!-undefined?
                           unsafe-mode? enforce-constant? allow-inline? no-prompt?
                           prim-knowns primitives get-import-knowns import-keys)
   (with-deterministic-gensym
@@ -134,7 +135,7 @@
        ;; Schemify the body, collecting information about defined names:
        (define-values (new-body defn-info mutated)
          (schemify-body* bodys prim-knowns primitives imports exports
-                         serializable?-box datum-intern? for-interp? allow-set!-undefined? add-import! #f
+                         serializable?-box datum-intern? allow-set!-undefined? add-import! target
                          unsafe-mode? enforce-constant? allow-inline? no-prompt? #t))
        (define all-grps (append grps (reverse new-grps)))
        (values
@@ -188,28 +189,28 @@
 ;; ----------------------------------------
 
 (define (schemify-body l prim-knowns primitives imports exports
-                       for-cify? unsafe-mode? no-prompt? explicit-unnamed?)
+                       target unsafe-mode? no-prompt? explicit-unnamed?)
   (with-deterministic-gensym
     (define-values (new-body defn-info mutated)
       (schemify-body* l prim-knowns primitives imports exports
-                      #f #f #f #f (lambda (im ext-id index) #f)
+                      #f #f #f (lambda (im ext-id index) #f)
-                      for-cify? unsafe-mode? #t #t no-prompt? explicit-unnamed?))
+                      target unsafe-mode? #t #t no-prompt? explicit-unnamed?))
     new-body))
 
 (define (schemify-body* l prim-knowns primitives imports exports
-                        serializable?-box datum-intern? for-interp? allow-set!-undefined? add-import!
+                        serializable?-box datum-intern? allow-set!-undefined? add-import!
-                        for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?)
+                        target unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?)
   ;; Keep simple checking efficient by caching results
   (define simples (make-hasheq))
   ;; Various conversion steps need information about mutated variables,
   ;; where "mutated" here includes visible implicit mutation, such as
   ;; a variable that might be used before it is defined:
-  (define mutated (mutated-in-body l exports prim-knowns (hasheq) imports simples unsafe-mode? for-cify? enforce-constant?))
+  (define mutated (mutated-in-body l exports prim-knowns (hasheq) imports simples unsafe-mode? target enforce-constant?))
   ;; Make another pass to gather known-binding information:
   (define knowns
     (for/fold ([knowns (hasheq)]) ([form (in-list l)])
       (define-values (new-knowns info)
-        (find-definitions form prim-knowns knowns imports mutated simples unsafe-mode? for-cify?
+        (find-definitions form prim-knowns knowns imports mutated simples unsafe-mode? target
                           #:primitives primitives
                           #:optimize? #t))
       new-knowns))
@@ -231,7 +232,7 @@
       (define (make-set-variables)
         ;; Resulting list of assinments will be reversed
         (cond
-          [(or for-cify? for-interp?)
+          [(or (aim? target 'cify) (aim? target 'interp))
            (for/list ([id (in-list accum-ids)]
                       #:when (hash-ref exports (unwrap id) #f))
              (make-set-variable id exports knowns mutated))]
@@ -256,7 +257,7 @@
                   [else
                    (loop (cdr accum-ids) consistent-ids)])]))]))
       (define (make-expr-defns es)
-        (if (or for-interp? for-cify?)
+        (if (or (aim? target 'cify) (aim? target 'interp))
             (reverse es)
             (for/list ([e (in-list (reverse es))])
               (make-expr-defn e))))
@@ -278,7 +279,7 @@
                                      prim-knowns primitives knowns mutated imports exports simples
                                      allow-set!-undefined?
                                      add-import!
-                                     serializable?-box datum-intern? for-cify? for-interp?
+                                     serializable?-box datum-intern? target
                                      unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
                                      (if (and no-prompt? (null? (cdr l)))
                                          'tail
@@ -299,7 +300,7 @@
                (define id (car ids))
                (define k (match schemified
                            [`(define ,id ,rhs)
-                            (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? for-cify?
+                            (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target
                                          #:post-schemify? #t)]))
                (if k
                    (hash-set knowns (unwrap id) k)
@@ -314,7 +315,7 @@
                 [(null? ids) (if next-k
                                  (next-k accum-exprs accum-ids next-knowns)
                                  (loop (cdr l) mut-l accum-exprs accum-ids next-knowns))]
-                [(or (or for-interp? for-cify?)
+                [(or (or (aim? target 'interp) (aim? target 'cify))
                      (via-variable-mutated-state? (hash-ref mutated (unwrap (car ids)) #f)))
                  (define id (unwrap (car ids)))
                  (cond
@@ -356,7 +357,7 @@
                 (for/list ([id (in-list ids)])
                   (make-define-variable id exports knowns mutated extra-variables)))
               (cons
-               (if for-interp?
+               (if (aim? target 'interp)
                    expr
                    (make-expr-defn expr))
                (append defns (loop (cdr l) mut-l null null knowns)))])))
@@ -474,7 +475,7 @@
 ;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
 ;; effectively canceled with a mapping in `knowns`.
 (define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import!
-                  serializable?-box datum-intern? for-cify? for-interp? unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
+                  serializable?-box datum-intern? target unsafe-mode? allow-inline? no-prompt? explicit-unnamed?
                   wcm-state)
   ;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks)
   (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state wcm-state] [v v])
@@ -501,10 +502,11 @@
                          ,make2
                          ,?2
                          ,make-acc/muts ...)))
-            #:guard (not (or for-interp? for-cify?))
+            #:guard (not (or (aim? target 'interp) (aim? target 'cify)))
             (define new-seq
-              (struct-convert v prim-knowns knowns imports mutated
+              (struct-convert v prim-knowns knowns imports exports mutated
-                              (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) no-prompt?))
+                              (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v))
+                              target no-prompt?))
             (or new-seq
                 (match v
                   [`(,_ ,ids ,rhs)
@@ -534,7 +536,7 @@
                (define new-knowns
                  (for/fold ([knowns knowns]) ([id (in-list ids)]
                                               [rhs (in-list rhss)])
-                   (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? for-cify?))
+                   (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target))
                    (if k
                        (hash-set knowns (unwrap id) k)
                        knowns)))
@@ -559,18 +561,18 @@
            [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...)
             `(begin ,@(schemify-body rhss 'fresh) ,@(schemify-body bodys wcm-state))]
            [`(let-values ([,idss ,rhss] ...) ,bodys ...)
-            (or (and (not (or for-interp? for-cify?))
+            (or (and (not (or (aim? target 'interp) (aim? target 'cify)))
                      (struct-convert-local v prim-knowns knowns imports mutated simples
                                            (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v))
                                            #:unsafe-mode? unsafe-mode?
-                                           #:for-cify? for-cify?))
+                                           #:target target))
                 (unnest-let
                  (left-to-right/let-values idss
                                            (for/list ([rhs (in-list rhss)])
                                              (schemify rhs 'fresh))
                                            (schemify-body bodys wcm-state)
                                            mutated
-                                           for-cify?)
+                                           target)
                  prim-knowns knowns imports mutated simples))]
            [`(letrec-values () ,bodys ...)
             (schemify `(begin . ,bodys) wcm-state)]
@@ -583,7 +585,7 @@
             (define-values (rhs-knowns body-knowns)
               (for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
                                                                     [rhs (in-list rhss)])
-                (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? for-cify?))
+                (define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode? target))
                 (define u-id (unwrap id))
                 (cond
                   [(too-early-mutated-state? (hash-ref mutated u-id #f))
@@ -592,7 +594,7 @@
                   [else (values rhs-knowns body-knowns)])))
             (unnest-let
              (letrec-conversion
-              ids mutated for-cify?
+              ids mutated target
               `(letrec* ,(for/list ([id (in-list ids)]
                                     [rhs (in-list rhss)])
                            `[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)])
@@ -604,7 +606,7 @@
               [(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples
                                      (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v))
                                      #:unsafe-mode? unsafe-mode?
-                                     #:for-cify? for-cify?)
+                                     #:target target)
                => (lambda (form) form)]
               [(letrec-splitable-values-binding? idss rhss)
                (schemify
@@ -619,7 +621,7 @@
                ;;            ... ...)
                ;;    ....)
                (letrec-conversion
-                idss mutated for-cify?
+                idss mutated target
                 `(letrec* ,(apply
                             append
                             (for/list ([ids (in-list idss)]
@@ -628,12 +630,12 @@
                                 (cond
                                   [(null? ids)
                                    `([,(deterministic-gensym "lr")
-                                      ,(make-let-values null rhs '(void) for-cify?)])]
+                                      ,(make-let-values null rhs '(void) target)])]
                                   [(and (pair? ids) (null? (cdr ids)))
                                    `([,(car ids) ,rhs])]
                                   [else
                                    (define lr (deterministic-gensym "lr"))
-                                   `([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)]
+                                   `([,lr ,(make-let-values ids rhs `(vector . ,ids) target)]
                                      ,@(for/list ([id (in-list ids)]
                                                   [pos (in-naturals)])
                                          `[,id (unsafe-vector*-ref ,lr ,pos)]))]))))
@@ -652,7 +654,7 @@
                `(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
                        ,(ensure-single-valued s-val knowns prim-knowns imports mutated)
                        ,s-body)]
-              [for-cify?
+              [(aim? target 'cify)
                `(with-continuation-mark ,s-key ,s-val ,s-body)]
               [else
                (define mode
@@ -686,7 +688,7 @@
               [else
                (cond
                  [(and (too-early-mutated-state? state)
-                       (not for-cify?))
+                       (not (aim? target 'cify)))
                   (define tmp (deterministic-gensym "set"))
                   `(let ([,tmp ,new-rhs])
                      (check-not-unsafe-undefined/assign ,id ',(too-early-mutated-state-name state int-id))
@@ -745,7 +747,7 @@
                 [else
                  (left-to-right/app 'equal?
                                     (list exp1 exp2)
-                                    #t for-cify?
+                                    #t target
                                     prim-knowns knowns imports mutated simples)]))]
            [`(call-with-values ,generator ,receiver)
             (cond
@@ -754,13 +756,13 @@
                         (eq? (unwrap receiver) 'list)))
                `(call-with-values ,(schemify generator 'fresh) ,(schemify receiver 'fresh))]
               [else
-               (left-to-right/app (if for-cify? 'call-with-values '#%call-with-values)
+               (left-to-right/app (if (aim? target 'cify) 'call-with-values '#%call-with-values)
                                   (list (schemify generator 'fresh) (schemify receiver 'fresh))
-                                  #t for-cify?
+                                  #t target
                                   prim-knowns knowns imports mutated simples)])]
            [`(single-flonum-available?)
             ;; Fold to a boolean to allow earlier simplification
-            for-cify?]
+            (aim? target 'cify)]
            [`((letrec-values ,binds ,rator) ,rands ...)
             (schemify `(letrec-values ,binds (,rator . ,rands)) wcm-state)]
            [`(,rator ,exps ...)
@@ -812,11 +814,18 @@
                   body
                   `(let ([,tmp ,e])
                      ,body)))
+            (define (inline-struct-constructor k s-rator im args)
+              (define type-id (and (bitwise-bit-set? (known-procedure-arity-mask k) (length args))
+                                   (inline-type-id k im add-import! mutated imports)))
+              (cond
+                [type-id
+                 (left-to-right/app 'unsafe-struct
+                                    (cons (schemify type-id 'fresh) args)
+                                    #t target
+                                    prim-knowns knowns imports mutated simples)]
+                [else #f]))
             (define (inline-struct-predicate k s-rator im args)
-              ;; For imported predicates on authentic structure types, it's worth
+              (define type-id (and (known-struct-predicate-authentic? k)
-              ;; inlining the predicate to enable cptypes optimizations.
-              (define type-id (and im
-                                   (known-struct-predicate-authentic? k)
                                    (pair? args)
                                    (null? (cdr args))
                                    (inline-type-id k im add-import! mutated imports)))
@@ -828,24 +837,23 @@
                            ques)]
                 [else #f]))
             (define (inline-field-access k s-rator im args)
-              ;; For imported accessors or for JIT mode, inline the
+              ;; Inline the selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`.
-              ;; selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`.
+              (define type-id (and (pair? args)
-              (define type-id (and (or im for-interp?)
-                                   (pair? args)
                                    (null? (cdr args))
                                    (inline-type-id k im add-import! mutated imports)))
               (cond
                 [type-id
                  (define tmp (maybe-tmp (car args) 'v))
-                 (define sel `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
+                 (define sel (if unsafe-mode?
-                                  (unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
+                                 `(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
-                                  (,s-rator ,tmp)))
+                                 `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
+                                      (unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
+                                      (,s-rator ,tmp))))
                  (wrap-tmp tmp (car args)
                            sel)]
                 [else #f]))
             (define (inline-field-mutate k s-rator im args)
-              (define type-id (and (or im for-interp?)
+              (define type-id (and (pair? args)
-                                   (pair? args)
                                    (pair? (cdr args))
                                    (null? (cddr args))
                                    (inline-type-id k im add-import! mutated imports)))
@@ -853,9 +861,11 @@
                 [type-id
                  (define tmp (maybe-tmp (car args) 'v))
                  (define tmp-rhs (maybe-tmp (cadr args) 'rhs))
-                 (define mut `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
+                 (define mut (if unsafe-mode?
-                                  (unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
+                                 `(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
-                                  (,s-rator ,tmp ,tmp-rhs)))
+                                 `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
+                                      (unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
+                                      (,s-rator ,tmp ,tmp-rhs))))
                  (wrap-tmp tmp (car args)
                            (wrap-tmp tmp-rhs (cadr args)
                                      mut))]
@@ -873,17 +883,30 @@
                      => (lambda (e)
                           (left-to-right/app (car e)
                                              (cdr e)
-                                             #t for-cify?
+                                             #t target
                                              prim-knowns knowns imports mutated simples))]
-                    [(and (not for-cify?)
+                    [(and (not (or
+                                ;; Don't inline in cify mode, because cify takes care of it
+                                (aim? target 'cify)
+                                ;; Don't inline in 'system mode, because there will
+                                ;; be no `|#%struct-constructor| in the way, and
+                                ;; it's more readable to use the normal constructor name
+                                (aim? target 'system)))
+                          (known-struct-constructor? k)
+                          (inline-struct-constructor k s-rator im args))
+                     => (lambda (e) e)]
+                    [(and (not (or (aim? target 'cify)
+                                   (aim? target 'system)))
                           (known-struct-predicate? k)
                           (inline-struct-predicate k s-rator im args))
                      => (lambda (e) e)]
-                    [(and (not for-cify?)
+                    [(and (not (or (aim? target 'cify)
+                                   (aim? target 'system)))
                           (known-field-accessor? k)
                           (inline-field-access k s-rator im args))
                      => (lambda (e) e)]
-                    [(and (not for-cify?)
+                    [(and (not (or (aim? target 'cify)
+                                   (aim? target 'system)))
                           (known-field-mutator? k)
                           (inline-field-mutate k s-rator im args))
                      => (lambda (e) e)]
@@ -891,14 +914,14 @@
                           (known-procedure/has-unsafe? k))
                      (left-to-right/app (known-procedure/has-unsafe-alternate k)
                                         args
-                                        #t for-cify?
+                                        #t target
                                         prim-knowns knowns imports mutated simples)]
                     [else
                      (define plain-app? (or (known-procedure? k)
                                             (lambda? rator)))
                      (left-to-right/app s-rator
                                         args
-                                        plain-app? for-cify?
+                                        plain-app? target
                                         prim-knowns knowns imports mutated simples)])))]
            [`,_
             (let ([u-v (unwrap v)])
@@ -944,7 +967,7 @@
                             (schemify (known-copy-id k) wcm-state)]
                            [else v]))]
                    [(and (too-early-mutated-state? state)
-                         (not for-cify?))
+                         (not (aim? target 'cify)))
                     ;; Note: we don't get to this case if `knowns` has
                     ;; a mapping that says the variable is ready by now
                     `(check-not-unsafe-undefined ,v ',(too-early-mutated-state-name state u-v))]

racket/src/schemify/struct-convert.rkt

@@ -4,13 +4,15 @@
          "struct-type-info.rkt"
          "mutated-state.rkt"
          "find-definition.rkt"
-         "gensym.rkt")
+         "gensym.rkt"
+         "known.rkt"
+         "aim.rkt")
 
 (provide struct-convert
          struct-convert-local)
 
-(define (struct-convert form prim-knowns knowns imports mutated
+(define (struct-convert form prim-knowns knowns imports exports mutated
-                        schemify no-prompt?)
+                        schemify target no-prompt?)
   (match form
     [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...)
         (let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk))
@@ -55,6 +57,9 @@
                  (not (set!ed-mutated-state? (hash-ref mutated (unwrap struct:s) #f)))))
         (define can-impersonate? (not (struct-type-info-authentic? sti)))
         (define raw-s? (if can-impersonate? (deterministic-gensym (unwrap s?)) s?))
+        (define system-opaque? (and (aim? target 'system)
+                                    (or (not exports)
+                                        (eq? 'no (hash-ref exports (unwrap struct:s) 'no)))))
         `(begin
            (define ,struct:s (make-record-type-descriptor* ',(struct-type-info-name sti)
                                                            ,(schemify (struct-type-info-parent sti) knowns)
@@ -99,22 +104,33 @@
                                     ctr
                                     `(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti))))
                               (define name-expr (struct-type-info-constructor-name-expr sti))
-                              (match name-expr
+                              (define c
-                                [`#f
+                                (match name-expr
-                                 (wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
+                                  [`#f
-                                [`',sym
+                                   (wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
-                                 (if (symbol? sym)
+                                  [`',sym
-                                     (wrap-property-set ctr-expr 'inferred-name sym)
+                                   (if (symbol? sym)
-                                     `(procedure-rename ,ctr-expr ,name-expr))]
+                                       (wrap-property-set ctr-expr 'inferred-name sym)
-                                [`,_
+                                       `(procedure-rename ,ctr-expr ,name-expr))]
-                                 `(procedure-rename ,ctr-expr ,name-expr)])))
+                                  [`,_
-           (define ,raw-s? ,(name-procedure
+                                   `(procedure-rename ,ctr-expr ,name-expr)]))
-                             "" (struct-type-info-name sti) "" '|| "?"
+                              (if system-opaque?
-                             `(record-predicate ,struct:s)))
+                                  c
+                                  `(#%struct-constructor ,c ,(arithmetic-shift 1 (struct-type-info-field-count sti))))))
+           (define ,raw-s? ,(let ([p (name-procedure
+                                      "" (struct-type-info-name sti) "" '|| "?"
+                                      `(record-predicate ,struct:s))])
+                              (if (or can-impersonate?
+                                      system-opaque?)
+                                  p
+                                  `(#%struct-predicate ,p))))
            ,@(if can-impersonate?
-                 `((define ,s? ,(name-procedure
+                 `((define ,s? ,(let ([p (name-procedure
-                                 "" (struct-type-info-name sti) "" '|| "?"
+                                          "" (struct-type-info-name sti) "" '|| "?"
-                                 `(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))))
+                                          `(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))])
+                                  (if system-opaque?
+                                      p
+                                      `(#%struct-predicate ,p)))))
                  null)
            ,@(for/list ([acc/mut (in-list acc/muts)]
                         [make-acc/mut (in-list make-acc/muts)])
@@ -122,52 +138,53 @@
                (match make-acc/mut
                  [`(make-struct-field-accessor ,(? (lambda (v) (wrap-eq? v -ref))) ,pos ',field-name)
                   (define raw-def `(define ,raw-acc/mut
-                                     ,(name-procedure
+                                     ,(let ([p (name-procedure
-                                       "" (struct-type-info-name sti) "-" field-name ""
+                                                "" (struct-type-info-name sti) "-" field-name ""
-                                       `(record-accessor ,struct:s ,pos))))
+                                                `(record-accessor ,struct:s ,pos))])
+                                        (if (or can-impersonate?
+                                                system-opaque?)
+                                            p
+                                            `(#%struct-field-accessor ,p ,struct:s ,pos)))))
                   (if can-impersonate?
                       `(begin
                          ,raw-def
                          (define ,acc/mut
-                           ,(name-procedure
+                           ,(let ([p (name-procedure
-                             "" (struct-type-info-name sti) "-" field-name ""
+                                      "" (struct-type-info-name sti) "-" field-name ""
-                             `(lambda (s) (if (,raw-s? s)
+                                      `(lambda (s) (if (,raw-s? s)
-                                              (,raw-acc/mut s)
+                                                       (,raw-acc/mut s)
-                                              ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
+                                                       ($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
-                                                                       ',(struct-type-info-name sti) ',field-name)))))))
+                                                                                ',(struct-type-info-name sti) ',field-name)))))])
+                              (if system-opaque?
+                                  p
+                                  `(#%struct-field-accessor ,p ,struct:s ,pos)))))
                       raw-def)]
                  [`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ',field-name)
                   (define raw-def `(define ,raw-acc/mut
-                                     ,(name-procedure
+                                     ,(let ([p (name-procedure
-                                       "set-" (struct-type-info-name sti) "-" field-name "!"
+                                                "set-" (struct-type-info-name sti) "-" field-name "!"
-                                       `(record-mutator ,struct:s ,pos))))
+                                                `(record-mutator ,struct:s ,pos))])
+                                        (if (or can-impersonate?
+                                                system-opaque?)
+                                            p
+                                            `(#%struct-field-mutator ,p ,struct:s ,pos)))))
                   (define abs-pos (+ pos (- (struct-type-info-field-count sti)
                                             (struct-type-info-immediate-field-count sti))))
                   (if can-impersonate?
                       `(begin
                          ,raw-def
                          (define ,acc/mut
-                           ,(name-procedure
+                            ,(let ([p (name-procedure
-                             "set-" (struct-type-info-name sti) "-" field-name "!"
+                                       "set-" (struct-type-info-name sti) "-" field-name "!"
-                             `(lambda (s v) (if (,raw-s? s)
+                                       `(lambda (s v) (if (,raw-s? s)
-                                                (,raw-acc/mut s v)
+                                                          (,raw-acc/mut s v)
-                                                ($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
+                                                          ($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
-                                                                          ',(struct-type-info-name sti) ',field-name)))))))
+                                                                                    ',(struct-type-info-name sti) ',field-name)))))])
+                               (if system-opaque?
+                                   p
+                                   `(#%struct-field-mutator ,p ,struct:s ,pos)))))
                       raw-def)]
-                 [`,_ (error "oops")]))
+                 [`,_ (error "oops")])))]
-           (define ,(deterministic-gensym "effect")
-             (begin
-               (register-struct-constructor! ,make-s)
-               (register-struct-predicate! ,s?)
-               ,@(for/list ([acc/mut (in-list acc/muts)]
-                            [make-acc/mut (in-list make-acc/muts)])
-                   (match make-acc/mut
-                     [`(make-struct-field-accessor ,_ ,pos ,_)
-                      `(register-struct-field-accessor! ,acc/mut ,struct:s ,pos)]
-                     [`(make-struct-field-mutator ,_ ,pos ,_)
-                      `(register-struct-field-mutator! ,acc/mut ,struct:s ,pos)]
-                     [`,_ (error "oops")]))
-               (void))))]
        [else #f])]
     [`,_ #f]))
 
@@ -175,19 +192,19 @@
                               prim-knowns knowns imports mutated simples
                               schemify
                               #:unsafe-mode? unsafe-mode?
-                              #:for-cify? for-cify?)
+                              #:target target)
   (match form
     [`(,_ ([,ids ,rhs]) ,bodys ...)
      (define defn `(define-values ,ids ,rhs))
      (define new-seq
        (struct-convert defn
-                       prim-knowns knowns imports mutated
+                       prim-knowns knowns imports #f mutated
-                       schemify #t))
+                       schemify target #t))
      (and new-seq
           (match new-seq
             [`(begin . ,new-seq)
              (define-values (new-knowns info)
-               (find-definitions defn prim-knowns knowns imports mutated simples unsafe-mode? for-cify?
+               (find-definitions defn prim-knowns knowns imports mutated simples unsafe-mode? target
                                  #:optimize? #f))
              (cond
                [letrec?

racket/src/version/racket_version.h

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