suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: change struct procedure representation and inlining

Browse Source 
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
This commit is contained in:
Matthew Flatt 2020-12-08 16:32:50 -07:00
parent 0de549800e
commit e02c417de0
46 changed files with 2273 additions and 7052 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.makefile
View File

@ -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

12
Makefile
View File

@ -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
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.10-1
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.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 checkout 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.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)"

2
pkgs/base/info.rkt
View File

@ -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]))

4
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -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?)

13
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -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

4
pkgs/racket-test-core/tests/racket/thread.rktl
View File

@ -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

19
racket/src/ChezScheme/csug/objects.stex
View File

@ -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

2
racket/src/ChezScheme/makefiles/Mf-install.in
View File

@ -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

4
racket/src/ChezScheme/s/cmacros.ss
View File

@ -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)

3
racket/src/ChezScheme/s/primdata.ss
View File

@ -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])
)

5
racket/src/ChezScheme/s/prims.ss
View File

@ -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))

1
racket/src/bc/include/scheme.h
View File

@ -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 */

3
racket/src/bc/src/cify-startup.rkt
View File

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

2
racket/src/bc/src/error.c
View File

@ -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); \

3
racket/src/bc/src/fun.c
View File

@ -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;
}

16
racket/src/bc/src/startup.inc
View File

@ -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!"
" register-struct-predicate!"
" register-struct-field-accessor!"
" register-struct-field-mutator!"
" #%struct-constructor"
" #%struct-predicate"
" #%struct-field-accessor"
" #%struct-field-mutator"
" unsafe-struct?"
" unsafe-struct"
" raise-binding-result-arity-error"
" structure-type-lookup-prefab-uid"
" struct-type-constructor-add-guards"

42
racket/src/bc/src/struct.c
View File

@ -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)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_BROKEN_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_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)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
return (((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_INDEXED_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)
|| STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR))
return (((STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_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,

12
racket/src/cs/README.txt
View File

@ -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
---------------------

2
racket/src/cs/compile-file.ss
View File

@ -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

11
racket/src/cs/convert.rkt
View File

@ -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")

3
racket/src/cs/demo/struct.ss
View File

@ -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)

2
racket/src/cs/linklet.sls
View File

@ -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?

9
racket/src/cs/primitive/internal.ss
View File

@ -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)]

9
racket/src/cs/rumble.sls
View File

@ -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
register-struct-predicate! ; not exported to Racket
register-struct-field-accessor! ; not exported to Racket
register-struct-field-mutator! ; not exported to Racket
|#%struct-constructor| ; not exported to Racket
|#%struct-predicate| ; not exported to Racket
|#%struct-field-accessor| ; 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!

9
racket/src/cs/rumble/impersonator.ss
View File

@ -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))
(record? val (car rtd+pos))
orig-proc (cdr pos+rtd) (struct-mutator-pos->key2 (car pos+rtd))
(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))]))])

6
racket/src/cs/rumble/procedure.ss
View File

@ -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))])))
;; ----------------------------------------

162
racket/src/cs/rumble/struct.ss
View File

@ -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)
(#%$app/no-inline add-to-table! struct-constructors p #t))
(define (|#%struct-constructor| p arity-mask)
(make-wrapper-procedure p arity-mask 'constructor))
(define (register-struct-predicate! p)
(#%$app/no-inline add-to-table! struct-predicates p #t))
(define (|#%struct-predicate| p)
(make-wrapper-procedure p 2 'predicate))
(define (register-struct-field-accessor! p rtd pos)
(#%$app/no-inline add-to-table! struct-field-accessors p (cons rtd pos)))
(define (|#%struct-field-accessor| p rtd pos)
(make-wrapper-procedure p 2 (cons rtd pos)))
(define (register-struct-field-mutator! p rtd pos)
(#%$app/no-inline add-to-table! struct-field-mutators p (cons rtd pos)))
(define (|#%struct-field-mutator| p rtd pos)
(make-wrapper-procedure p 4 (cons pos rtd)))
(define (struct-constructor-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(eq-hashtable-contains? struct-constructors v))))
(let ([v (strip-impersonator v)])
(and (wrapper-procedure? v)
(eq? 'constructor (wrapper-procedure-data v)))))
(define (struct-predicate-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(eq-hashtable-contains? struct-predicates v))))
(let ([v (strip-impersonator v)])
(and (wrapper-procedure? v)
(eq? 'predicate (wrapper-procedure-data v)))))
(define (struct-accessor-procedure? v)
(and (procedure? v)
(let ([v (strip-impersonator v)])
(or (position-based-accessor? v)
(eq-hashtable-contains? struct-field-accessors v)))))
(let ([v (strip-impersonator v)])
(or (position-based-accessor? v)
(and (wrapper-procedure? 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)])
(or (position-based-mutator? v)
(eq-hashtable-contains? struct-field-mutators v)))))
(let ([v (strip-impersonator v)])
(or (position-based-mutator? v)
(and (wrapper-procedure? 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)
(position-based-mutator-offset v))
(eq-hashtable-ref struct-field-mutators v #f)))
(cons (position-based-mutator-offset v)
(position-based-mutator-rtd v))
(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
pred
(|#%struct-constructor| ctr (procedure-arity-mask ctr))
(|#%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)
wrap-p))]
(|#%struct-field-accessor| wrap-p rtd pos)))]
[(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)
wrap-p))]
(|#%struct-field-mutator| wrap-p rtd pos)))]
[(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* ([c (record-constructor rtd*)]
[fi (struct-type-field-info rtd*)]
[auto-field-adder (get-field-info-auto-adder fi)]
[name (or name
(string->symbol (format "make-~a" (record-type-name rtd*))))])
(cond
[auto-field-adder
(procedure-rename
(procedure-reduce-arity
(lambda args
(apply c (reverse (auto-field-adder (reverse args)))))
(get-field-info-init*-count fi))
name)]
[else (procedure-rename c name)]))
rtd*
#f)])
(register-struct-constructor! ctr)
(let ([ctr (let* ([c (record-constructor rtd*)]
[fi (struct-type-field-info rtd*)]
[init*-count (get-field-info-init*-count fi)]
[init*-count-mask (bitwise-arithmetic-shift-left 1 init*-count)]
[auto-field-adder (get-field-info-auto-adder fi)]
[name (or name
(string->symbol (format "make-~a" (record-type-name rtd*))))])
(|#%struct-constructor|
(struct-type-constructor-add-guards
(cond
[auto-field-adder
(procedure-rename
(procedure-reduce-arity-mask
(lambda args
(apply c (reverse (auto-field-adder (reverse args)))))
init*-count-mask)
name)]
[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
(lambda (v)
(or (record? v rtd*)
(and (impersonator? v)
(record? (impersonator-val v) rtd*)))))])
(register-struct-predicate! pred)
pred)))
(|#%struct-predicate|
(escapes-ok
(lambda (v)
(or (record? v rtd*)
(and (impersonator? v)
(record? (impersonator-val v) rtd*))))))))
;; ----------------------------------------
@ -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)
(and (impersonator? v)
(authentic-name? (impersonator-val v))))))
(define name? (|#%struct-predicate|
(lambda (v) (or (authentic-name? v)
(and (impersonator? v)
(authentic-name? (impersonator-val v)))))))
(define name-field
(let ([name-field (record-accessor struct:name field-index)])
(lambda (v)
(if (authentic-name? v)
(name-field v)
(pariah (impersonate-ref name-field struct:name field-index v 'name 'field))))))
(|#%struct-field-accessor|
(lambda (v)
(if (authentic-name? v)
(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)))))))])))

2327
racket/src/cs/schemified/expander.scm
View File

File diff suppressed because it is too large Load Diff

1190
racket/src/cs/schemified/io.scm
View File

File diff suppressed because it is too large Load Diff

394
racket/src/cs/schemified/known.scm
View File

@ -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
(begin
(register-struct-constructor! known-mutator)
(register-struct-predicate! known-mutator?)
(register-struct-field-accessor! known-mutator-type struct:known-mutator 0)
(void)))
(define struct:known-struct-constructor
(make-record-type-descriptor*
'known-struct-constructor
(if (struct-type? struct:known-constructor)
struct:known-constructor
(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
(begin
(register-struct-constructor! known-field-mutator)
(register-struct-predicate! known-field-mutator?)
(register-struct-field-accessor!
known-field-mutator-type-id
struct:known-field-mutator
0)
(register-struct-field-accessor!
known-field-mutator-pos
struct:known-field-mutator
1)
(void)))
(define struct:known-struct-constructor/need-imports
(make-record-type-descriptor*
'known-struct-constructor/need-imports
(if (struct-type? struct:known-struct-constructor)
struct:known-struct-constructor
(check-struct-type 'struct struct:known-struct-constructor))
(structure-type-lookup-prefab-uid
'known-struct-constructor/need-imports
(if (struct-type? struct:known-struct-constructor)
struct:known-struct-constructor
(check-struct-type 'struct struct:known-struct-constructor))
1
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))

238
racket/src/cs/schemified/regexp.scm
View File

@ -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

3539
racket/src/cs/schemified/schemify.scm
View File

File diff suppressed because it is too large Load Diff

898
racket/src/cs/schemified/thread.scm
View File

File diff suppressed because it is too large Load Diff

19
racket/src/expander/README.txt
View File

@ -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

9
racket/src/expander/compile/built-in-symbol.rkt
View File

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

9
racket/src/schemify/aim.rkt Normal file
View File

@ -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)]))

8
racket/src/schemify/find-definition.rkt
View File

@ -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)]

13
racket/src/schemify/infer-known.rkt
View File

@ -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]

17
racket/src/schemify/inline.rkt
View File

@ -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

4
racket/src/schemify/known.rkt
View File

@ -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)

19
racket/src/schemify/left-to-right.rkt
View File

@ -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))]

7
racket/src/schemify/letrec.rkt
View File

@ -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)

4
racket/src/schemify/mutated.rkt
View File

@ -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)

141
racket/src/schemify/schemify.rkt
View File

@ -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)
for-cify? unsafe-mode? #t #t no-prompt? explicit-unnamed?))
#f #f #f (lambda (im ext-id index) #f)
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!
for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt? explicit-unnamed?)
serializable?-box datum-intern? allow-set!-undefined? add-import!
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
(lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) no-prompt?))
(struct-convert v prim-knowns knowns imports exports mutated
(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
;; inlining the predicate to enable cptypes optimizations.
(define type-id (and im
(known-struct-predicate-authentic? k)
(define type-id (and (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
;; selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`.
(define type-id (and (or im for-interp?)
(pair? args)
;; Inline the selector with an `unsafe-struct?` test plus `unsafe-struct*-ref`.
(define type-id (and (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))
(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
(,s-rator ,tmp)))
(define sel (if unsafe-mode?
`(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
`(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?)
(pair? args)
(define type-id (and (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))
(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
(,s-rator ,tmp ,tmp-rhs)))
(define mut (if unsafe-mode?
`(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,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))]

125
racket/src/schemify/struct-convert.rkt
View File

@ -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
schemify no-prompt?)
(define (struct-convert form prim-knowns knowns imports exports mutated
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
[`#f
(wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
[`',sym
(if (symbol? sym)
(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
"" (struct-type-info-name sti) "" '|| "?"
`(record-predicate ,struct:s)))
(define c
(match name-expr
[`#f
(wrap-property-set ctr-expr 'inferred-name (struct-type-info-name sti))]
[`',sym
(if (symbol? sym)
(wrap-property-set ctr-expr 'inferred-name sym)
`(procedure-rename ,ctr-expr ,name-expr))]
[`,_
`(procedure-rename ,ctr-expr ,name-expr)]))
(if system-opaque?
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
"" (struct-type-info-name sti) "" '|| "?"
`(lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f)))))))
`((define ,s? ,(let ([p (name-procedure
"" (struct-type-info-name sti) "" '|| "?"
`(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
"" (struct-type-info-name sti) "-" field-name ""
`(record-accessor ,struct:s ,pos))))
,(let ([p (name-procedure
"" (struct-type-info-name sti) "-" field-name ""
`(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
"" (struct-type-info-name sti) "-" field-name ""
`(lambda (s) (if (,raw-s? s)
(,raw-acc/mut s)
($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
',(struct-type-info-name sti) ',field-name)))))))
,(let ([p (name-procedure
"" (struct-type-info-name sti) "-" field-name ""
`(lambda (s) (if (,raw-s? s)
(,raw-acc/mut s)
($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s
',(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
"set-" (struct-type-info-name sti) "-" field-name "!"
`(record-mutator ,struct:s ,pos))))
,(let ([p (name-procedure
"set-" (struct-type-info-name sti) "-" field-name "!"
`(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
"set-" (struct-type-info-name sti) "-" field-name "!"
`(lambda (s v) (if (,raw-s? s)
(,raw-acc/mut s v)
($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
',(struct-type-info-name sti) ',field-name)))))))
,(let ([p (name-procedure
"set-" (struct-type-info-name sti) "-" field-name "!"
`(lambda (s v) (if (,raw-s? s)
(,raw-acc/mut s v)
($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v
',(struct-type-info-name sti) ',field-name)))))])
(if system-opaque?
p
`(#%struct-field-mutator ,p ,struct:s ,pos)))))
raw-def)]
[`,_ (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))))]
[`,_ (error "oops")])))]
[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
schemify #t))
prim-knowns knowns imports #f mutated
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?

2
racket/src/version/racket_version.h
View File

@ -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