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

Chez Scheme: make "immediate" consistently mean type-immediate

Browse Source 
Exposing `$immediate?` as just "immediate" will be useful to cptypes.
Meanwhile, introduce "fixmediate" as the term for a union of "fixnum"
and "immediate" (i.e., values that are not allocated).

The new terminology helps avoid internal inconsistencies, such as the
`Simmediatep` kernel macro meaning "immediate" while the `$immediate?`
primitive meant the union.
This commit is contained in:
Matthew Flatt 2021-02-28 08:38:53 -07:00
parent 04e78c4bb7
commit 37ee8a793c
21 changed files with 82 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.makefile
View File

@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
RACKET_FOR_BUILD = $(RACKET)
# This branch name changes each time the pb boot files are updated:
PB_BRANCH == circa-8.0.0.7-1
PB_BRANCH == circa-8.0.0.10-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-8.0.0.7-1
PB_BRANCH = circa-8.0.0.10-1
PB_REPO = https://github.com/racket/pb
EXTRA_REPOS_BASE =
CS_CROSS_SUFFIX =
@ -309,18 +309,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-8.0.0.7-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.7-1:remotes/origin/circa-8.0.0.7-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.7-1
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-8.0.0.10-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.10-1:remotes/origin/circa-8.0.0.10-1 ; fi
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.10-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-8.0.0.7-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.7-1
cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.10-1
cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.10-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-8.0.0.7-1
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.10-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
racket/src/ChezScheme/c/alloc.c
View File

@ -374,7 +374,7 @@ void S_dirty_set(ptr *loc, ptr x) {
seginfo *si = SegInfo(addr_get_segment(TO_PTR(loc)));
if (si->use_marks) {
/* GC must be in progress */
if (!IMMEDIATE(x)) {
if (!FIXMEDIATE(x)) {
seginfo *t_si = SegInfo(ptr_get_segment(x));
if (t_si->generation < si->generation)
S_record_new_dirty_card(THREAD_GC(get_thread_context()), loc, t_si->generation);

38
racket/src/ChezScheme/c/gc.c
View File

@ -563,7 +563,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) {
#define relocate_pure_help(ppp, pp) do { \
seginfo *SI; \
if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \
if (!FIXMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \
if (SI->old_space) \
relocate_pure_help_help(ppp, pp, SI); \
ELSE_MEASURE_NONOLDSPACE(pp) \
@ -609,7 +609,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) {
static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
seginfo *si;
ptr pp = *ppp;
if (!IMMEDIATE(pp)
if (!FIXMEDIATE(pp)
&& (si = MaybeSegInfo(ptr_get_segment(pp))) != NULL
&& si->old_space) {
BLOCK_SET_THREAD(si->creator);
@ -639,7 +639,7 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
#define relocate_impure_help(ppp, pp, from_g) do { \
seginfo *SI; \
if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \
if (!FIXMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \
if (SI->old_space) \
relocate_impure_help_help(ppp, pp, from_g, SI); \
ELSE_MEASURE_NONOLDSPACE(pp) \
@ -673,7 +673,7 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) {
#define relocate_dirty(PPP, YOUNGEST) do { \
seginfo *_si; ptr *_ppp = PPP, _pp = *_ppp; IGEN _pg; \
if (!IMMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) { \
if (!FIXMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) { \
if (!_si->old_space) { \
_pg = _si->generation; \
} else { \
@ -815,7 +815,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) {
}
}
#define NONSTATICINHEAP(si, x) (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation)
#define NONSTATICINHEAP(si, x) (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation)
#define ALWAYSTRUE(si, x) (si = SegInfo(ptr_get_segment(x)), 1)
#define partition_guardians(LS, FILTER) do { \
ptr ls; seginfo *si; \
@ -1070,7 +1070,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) {
for (ls = count_roots_ls, i = 0; ls != Snil; ls = Scdr(ls), i++) {
ptr p = Scar(ls);
if (IMMEDIATE(p)) {
if (FIXMEDIATE(p)) {
count_roots[i].p = p;
count_roots[i].weak = 0;
} else {
@ -1106,7 +1106,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) {
for (i = 0; i < count_roots_len; i++) {
uptr total;
ptr p = count_roots[i].p;
if (IMMEDIATE(p)) {
if (FIXMEDIATE(p)) {
/* nothing to do */
} else {
seginfo *si = SegInfo(ptr_get_segment(p));
@ -1152,7 +1152,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) {
/* clear `counting_mask`s */
for (i = 0; i < count_roots_len; i++) {
ptr p = count_roots[i].p;
if (!IMMEDIATE(p)) {
if (!FIXMEDIATE(p)) {
seginfo *si = SegInfo(ptr_get_segment(p));
si->counting_mask = NULL;
}
@ -1368,7 +1368,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) {
pend_hold_ls = ls;
} else {
seginfo *si;
if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && si->old_space) {
if (!FIXMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && si->old_space) {
/* mark things reachable from `rep`, but not `rep` itself, unless
`rep` is immediately reachable from itself */
PUSH_BACKREFERENCE(ls)
@ -1885,7 +1885,7 @@ static void resweep_weak_pairs(seginfo *oldweakspacesegments) {
static void forward_or_bwp(pp, p) ptr *pp; ptr p; {
seginfo *si;
/* adapted from relocate */
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space && !new_marked(si, p)) {
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space && !new_marked(si, p)) {
if (FORWARDEDP(p, si)) {
*pp = GET_FWDADDRESS(p);
} else {
@ -2526,7 +2526,7 @@ static void resweep_dirty_weak_pairs(thread_gc *tgc) {
seginfo *si;
/* handle car field */
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
if (si->old_space) {
if (new_marked(si, p)) {
youngest = TARGET_GENERATION(si);
@ -2637,7 +2637,7 @@ static void check_ephemeron(thread_gc *tgc, ptr pe) {
from_g = GENERATION(pe);
p = Scar(pe);
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) {
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) {
if (SEGMENT_IS_LOCAL(si, p)) {
if (new_marked(si, p)) {
#ifndef NO_DIRTY_NEWSPACE_POINTERS
@ -2696,7 +2696,7 @@ static IGEN check_dirty_ephemeron(thread_gc *tgc, ptr pe, IGEN youngest) {
PUSH_BACKREFERENCE(pe);
p = Scar(pe);
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
if (si->old_space) {
if (SEGMENT_IS_LOCAL(si, p)) {
if (new_marked(si, p)) {
@ -3305,7 +3305,7 @@ static void add_ephemeron_to_pending_measure(thread_gc *tgc, ptr pe) {
seginfo *si;
ptr p = Scar(pe);
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space)
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space)
add_ephemeron_to_pending(tgc, pe);
else {
if (EPHEMERONPREVREF(pe))
@ -3326,7 +3326,7 @@ static void check_ephemeron_measure(thread_gc *tgc, ptr pe) {
EPHEMERONNEXT(pe) = 0;
p = Scar(pe);
if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL
if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL
&& (si->generation <= max_measure_generation)
&& (si->generation >= min_measure_generation)
&& (!(si->old_space) || !FORWARDEDP(p, si))
@ -3341,7 +3341,7 @@ static void check_ephemeron_measure(thread_gc *tgc, ptr pe) {
}
p = Scdr(pe);
if (!IMMEDIATE(p))
if (!FIXMEDIATE(p))
push_measure(tgc, p);
}
@ -3398,7 +3398,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) {
for (l = ls; l != Snil; l = Scdr(l)) {
ptr p = Scar(l);
if (!IMMEDIATE(p)) {
if (!FIXMEDIATE(p)) {
seginfo *si = SegInfo(ptr_get_segment(p));
if (!si->measured_mask)
@ -3416,7 +3416,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) {
measure_total = 0;
if (!IMMEDIATE(p)) {
if (!FIXMEDIATE(p)) {
seginfo *si = SegInfo(ptr_get_segment(p));
measure_mask_unset(si->counting_mask, si, p);
gc_measure_one(tgc, p);
@ -3432,7 +3432,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) {
for (l = ls; l != Snil; l = Scdr(l)) {
ptr p = Scar(l);
if (!IMMEDIATE(p)) {
if (!FIXMEDIATE(p)) {
seginfo *si = SegInfo(ptr_get_segment(p));
si->counting_mask = NULL;
}

14
racket/src/ChezScheme/c/gcwrapper.c
View File

@ -185,7 +185,7 @@ void S_set_minmarkgen(IGEN g) {
void S_immobilize_object(x) ptr x; {
seginfo *si;
if (IMMEDIATE(x))
if (FIXMEDIATE(x))
si = NULL;
else
si = MaybeSegInfo(ptr_get_segment(x));
@ -212,7 +212,7 @@ void S_immobilize_object(x) ptr x; {
void S_mobilize_object(x) ptr x; {
seginfo *si;
if (IMMEDIATE(x))
if (FIXMEDIATE(x))
si = NULL;
else
si = MaybeSegInfo(ptr_get_segment(x));
@ -261,7 +261,7 @@ static IBOOL remove_first_nomorep(x, pls, look) ptr x, *pls; IBOOL look; {
IBOOL Slocked_objectp(x) ptr x; {
seginfo *si; IGEN g; IBOOL ans; ptr ls;
if (IMMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1;
if (FIXMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1;
tc_mutex_acquire();
@ -299,7 +299,7 @@ void Slock_object(x) ptr x; {
seginfo *si; IGEN g;
/* weed out pointers that won't be relocated */
if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
if (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
ptr tc = get_thread_context();
tc_mutex_acquire();
THREAD_GC(tc)->during_alloc += 1;
@ -323,7 +323,7 @@ void Slock_object(x) ptr x; {
void Sunlock_object(x) ptr x; {
seginfo *si; IGEN g;
if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
if (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
ptr tc = get_thread_context();
tc_mutex_acquire();
THREAD_GC(tc)->during_alloc += 1;
@ -550,7 +550,7 @@ void S_addr_tell(ptr p) {
static void check_pointer(ptr *pp, IBOOL address_is_meaningful, ptr base, uptr seg, ISPC s, IBOOL aftergc) {
ptr p = *pp;
if (!IMMEDIATE(p)) {
if (!FIXMEDIATE(p)) {
seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
if (psi != NULL) {
if ((psi->space == space_empty)
@ -945,7 +945,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
found_eos = 1;
pp1 = pp2;
break;
} else if (!IMMEDIATE(p)) {
} else if (!FIXMEDIATE(p)) {
seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
if ((psi != NULL) && ((pg = psi->generation) < g)) {
if (pg < dirty) dirty = pg;

2
racket/src/ChezScheme/c/schlib.c
View File

@ -216,7 +216,7 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t
the C stack and we may end up in a garbage collection */
code = CP(tc);
if (Sprocedurep(code)) code = CLOSCODE(code);
if (!IMMEDIATE(code) && !Scodep(code))
if (!FIXMEDIATE(code) && !Scodep(code))
S_error_abort("S_call_help: invalid code pointer");
S_immobilize_object(code);

2
racket/src/ChezScheme/c/thread.c
View File

@ -277,7 +277,7 @@ static IBOOL destroy_thread(tc) ptr tc; {
for (ges = GUARDIANENTRIES(tc); ges != Snil; ges = next) {
obj = GUARDIANOBJ(ges);
next = GUARDIANNEXT(ges);
if (!IMMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) {
if (!FIXMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) {
INITGUARDIANNEXT(ges) = target;
target = ges;
}

2
racket/src/ChezScheme/c/types.h
View File

@ -552,7 +552,7 @@ typedef struct thread_gc {
#define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)TO_VOIDP((uptr)(x)+disp)),(y))
#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
#define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x))
#define FIXMEDIATE(x) (Sfixnump(x) || Simmediatep(x))
/* For `memcpy_aligned, that the first two arguments are word-aligned
and it would be ok to round up the length to a word size. But

2
racket/src/ChezScheme/c/vfasl.c
View File

@ -519,7 +519,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
/* offset is stored in place of constant-loading code: */
memcpy(&obj, TO_VOIDP((ptr)((uptr)co + a)), sizeof(ptr));
if (IMMEDIATE(obj)) {
if (FIXMEDIATE(obj)) {
if (Sfixnump(obj)) {
int tag = VFASL_RELOC_TAG(obj);
iptr pos = VFASL_RELOC_POS(obj);

4
racket/src/ChezScheme/mats/cptypes.ms
View File

@ -1174,8 +1174,8 @@
'(lambda (v)
(let loop ([i 0])
(when (fx< i (vector-length v))
(vector-set! v i (#3%$immediate i))
(vector-set! v i (#3%$fixmediate i))
(loop (fx+ i 1))))))
(cptypes-equivalent-expansion?
'(lambda (x y) (set-box! x (if (vector? y) #t (error 't))))
'(lambda (x y) (set-box! x (#3%$immediate (if (vector? y) #t (error 't)))))))
'(lambda (x y) (set-box! x (#3%$fixmediate (if (vector? y) #t (error 't)))))))

4
racket/src/ChezScheme/s/5_2.ss
View File

@ -353,7 +353,7 @@
(set! assv
(lambda (x alist)
(if (or (symbol? x) (#%$immediate? x))
(if (or (symbol? x) (fixmediate? x))
(ass-eq? x alist 'assv)
(do-assoc x alist 'assv eqv?))))
@ -363,7 +363,7 @@
[(string? x)
(do-assoc x alist 'assoc
(lambda (x y) (and (string? x) (string=? x y))))]
[(or (symbol? x) (#%$immediate? x))
[(or (symbol? x) (fixmediate? x))
(ass-eq? x alist 'assoc)]
[else
(do-assoc x alist 'assoc equal?)])))

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

@ -2197,6 +2197,11 @@
(define-constant time-collector-cpu 5)
(define-constant time-collector-real 6)
(define-syntax fixmediate?
(lambda (stx)
(syntax-case stx ()
[(_ e) #'(let ([v e]) (or (fixnum? v) ($immediate? v)))])))
;; ---------------------------------------------------------------------
;; vfasl

2
racket/src/ChezScheme/s/cp0.ss
View File

@ -5244,7 +5244,7 @@
[else
`(call ,preinfo ,pr ,e1 ,e2 ,e3)]))]
[(call ,preinfo ,pr ,e)
(guard (eq? (primref-name pr) '$immediate))
(guard (eq? (primref-name pr) '$fixmediate))
(context-case ctxt
[(ignored) (cp0 e ctxt env sc wd name moi)]
[else

11
racket/src/ChezScheme/s/cpnanopass.ss
View File

@ -3846,7 +3846,7 @@
(lambda (multiple-ref? type e)
(nanopass-case (L7 Expr) e
[(call ,info ,mdcl ,pr ,e)
(guard (eq? (primref-name pr) '$immediate))
(guard (eq? (primref-name pr) '$fixmediate))
(let-values ([(t dobind) (binder multiple-ref? type e)])
(values `(call ,info ,mdcl ,pr ,t) dobind))]
[else
@ -4124,7 +4124,7 @@
[(base index offset e build-assign build-remember-seq)
(nanopass-case (L7 Expr) e
[(call ,info ,mdcl ,pr ,e)
(guard (eq? (primref-name pr) '$immediate))
(guard (eq? (primref-name pr) '$fixmediate))
(build-assign base index offset e)]
[else
(if (nanopass-case (L7 Expr) e
@ -6098,11 +6098,8 @@
,(%constant strue)
,(%typed-object-check mask-inexactnum type-inexactnum ,e)))])
(define-inline 2 $immediate?
[(e) (bind #t (e)
`(if ,(%type-check mask-fixnum type-fixnum ,e)
,(%constant strue)
,(%type-check mask-immediate type-immediate ,e)))])
(define-inline 3 $immediate
[(e) (bind #t (e) (%type-check mask-immediate type-immediate ,e))])
(define-inline 3 $fixmediate
[(e) e])
(define-inline 3 $inexactnum-real-part

21
racket/src/ChezScheme/s/cptypes.ss
View File

@ -698,17 +698,16 @@ Notes:
(define (primref->unsafe-primref pr)
(lookup-primref 3 (primref-name pr)))
(define (predicate-implies-immediate? x)
(define (predicate-implies-fixmediate? x)
(and (not (eq? x 'ptr)) ;fast path to avoid duplicated computation
(or (check-constant-is? x (lambda (x) (and ($immediate? x)
(not (fixnum? x)))))
(or (check-constant-is? x $immediate?)
(predicate-implies? x 'fixnum)
(predicate-implies? x 'boolean)
(predicate-implies? x 'char))))
(define (non-literal-immediate? e x)
(define (non-literal-fixmediate? e x)
(and (not (check-constant-is? e (lambda (e) #t)))
(predicate-implies-immediate? x)))
(predicate-implies-fixmediate? x)))
(module ()
@ -917,9 +916,9 @@ Notes:
(define-specialize 2 set
[(args ... val) (values `(call ,preinfo ,pr
,args ...
,(if (non-literal-immediate? val (get-type val))
,(if (non-literal-fixmediate? val (get-type val))
`(call ,(make-preinfo-call)
,(lookup-primref 3 '$immediate)
,(lookup-primref 3 '$fixmediate)
,val)
val))
ret ntypes #f #f)])]))
@ -1550,8 +1549,8 @@ Notes:
types1
new-types)])))])))])]
[(set! ,maybe-src ,x ,[e 'value types plxc -> e ret types t-types f-types])
(values `(set! ,maybe-src ,x ,(if (non-literal-immediate? e ret)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$immediate) ,e)
(values `(set! ,maybe-src ,x ,(if (non-literal-fixmediate? e ret)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$fixmediate) ,e)
e))
void-rec types #f #f)]
[(call ,preinfo ,pr ,e* ...)
@ -1622,9 +1621,9 @@ Notes:
(values `(record-set! ,rtd ,type ,index ,e1
,(cond
[(and (eq? type 'scheme-object)
(non-literal-immediate? e2 ret2))
(non-literal-fixmediate? e2 ret2))
`(call ,(make-preinfo-call)
,(lookup-primref 3 '$immediate)
,(lookup-primref 3 '$fixmediate)
,e2)]
[else e2]))
void-rec

6
racket/src/ChezScheme/s/inspect.ss
View File

@ -2591,7 +2591,7 @@
(define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
(define compute-size
(lambda (x)
(if (or ($immediate? x)
(if (or (fixmediate? x)
(let ([g ($generation x)])
(or (not g) (fx> g maxgen))))
0
@ -2784,7 +2784,7 @@
rtd-counts phantom)
(define compute-composition!
(lambda (x)
(unless (or ($immediate? x)
(unless (or (fixmediate? x)
(let ([g ($generation x)])
(or (not g) (fx> g maxgen))))
(let ([a (eq-hashtable-cell seen-ht x #f)])
@ -2945,7 +2945,7 @@
(lambda (x path next-proc)
(let ([path (cons x path)])
(cond
[(or ($immediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen))))
[(or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen))))
(if (pred x)
(begin (set! saved-next-proc next-proc) path)
(next-proc))]

2
racket/src/ChezScheme/s/library.ss
View File

@ -1473,7 +1473,7 @@
[else #f])))
(define-library-entry (memv x ls)
(if (or (symbol? x) (#%$immediate? x))
(if (or (symbol? x) (fixmediate? x))
(memq x ls)
(let memv ([ls ls])
(and (not (null? ls))

2
racket/src/ChezScheme/s/mkgc.ss
View File

@ -2058,7 +2058,7 @@
(code
"{ /* measure */"
(format " ptr r_p = ~a;" e)
" if (!IMMEDIATE(r_p))"
" if (!FIXMEDIATE(r_p))"
" push_measure(tgc, r_p);"
"}"))

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

@ -1964,6 +1964,7 @@
($filter-conv [flags single-valued])
($filter-foreign-type [flags single-valued])
($fixed-path? [sig [(string) -> (boolean)]] [flags pure safeongoodargs])
($fixmediate [sig [(ptr) -> (ptr)]] [flags pure discard])
($flvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure])
($flvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard])
($<= [flags single-valued])
@ -2165,8 +2166,7 @@
($hashtable-veclen [flags discard])
($ht-minlen [flags single-valued discard])
($ht-veclen [flags single-valued discard])
($immediate [sig [(ptr) -> (ptr)]] [flags pure discard])
($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted]) ; no mifoldable due to fixnum
($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
($impoops [flags abort-op])
($import-library [flags single-valued])
($inexactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])

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

@ -1412,12 +1412,6 @@
(lambda (b)
(#3%immutable-box? b)))
(define-who $immediate
(lambda (x)
(if ($immediate? x)
x
($oops who "~s is not an immediate value" x))))
(define pair? (lambda (x) (pair? x)))
(define box? (lambda (x) (box? x)))
@ -1593,6 +1587,14 @@
(display-string s)]))
(define $immediate? (lambda (x) ($immediate? x)))
;; Used to communicate fixmediateness from cptypes to cpnanopass:
(define-who $fixmediate
(lambda (x)
(if (fixmediate? x)
x
($oops who "~s is not a fixnum or immediate value" x))))
(define $inexactnum? (lambda (x) ($inexactnum? x)))
(define $inexactnum-real-part

10
racket/src/ChezScheme/s/print.ss
View File

@ -95,7 +95,7 @@
(define hashable?
(lambda (x)
(if ($immediate? x)
(if (fixmediate? x)
(eq? x black-hole)
(and
($object-in-heap? x)
@ -203,7 +203,7 @@
(define cyclic?
(lambda (x curlev lstlen)
(if ($immediate? x)
(if (fixmediate? x)
(if (eq? x black-hole) (not lev) #f)
(and ($object-in-heap? x)
(cond
@ -279,7 +279,7 @@
(constant cycle-node-max))])
(cond
[(fx= xlev 0) (or (not lev) (fx> lev (constant cycle-node-max)))]
[($immediate? x) (if (eq? x black-hole) (not lev) #f)]
[(fixmediate? x) (if (eq? x black-hole) (not lev) #f)]
[else
(and ($object-in-heap? x)
(cond
@ -322,7 +322,7 @@
(set! $make-graph-env
(lambda (who x lev len)
(and (if ($immediate? x)
(and (if (fixmediate? x)
(eq? x black-hole)
(and ($object-in-heap? x)
(or (pair? x) (vector? x) (stencil-vector? x) (box? x) (and ($record? x) (not (eq? x #!base-rtd))))))
@ -634,7 +634,6 @@ floating point returns with (1 0 -1 ...).
(cond
[($immediate? x)
(type-case x
[(fixnum?) (wrfixnum x r d? p)]
[(null?) (display-string "()" p)]
[(boolean?) (display-string (if x "#t" "#f") p)]
[(char?) (if d? (write-char x p) (wrchar x p))]
@ -644,6 +643,7 @@ floating point returns with (1 0 -1 ...).
[(void?) (display-string "#<void>" p)]
[(black-hole?) (wrblack-hole x r lev len d? env p)]
[else (display-string "#<garbage>" p)])]
[(fixnum? x) (wrfixnum x r d? p)]
[($object-in-heap? x)
(type-case x
[(symbol?)