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

less code for trap checks

Browse Source 
When a proceudre starts with a trap check, move the check to the very
beginning, even before checking the argument count. That way, event
detection can turn into a compact jump to an event handler, instead of
inserting a general call to `$event` in the procedure body.

original commit: 06b12d505698a2378734689370bb9e0f8eda06b9
This commit is contained in:
Matthew Flatt 2020-02-06 16:28:56 -07:00
parent 40c407e1c2
commit d4981dd8c3
11 changed files with 118 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
c/externs.h
View File

@ -350,6 +350,7 @@ extern void S_handle_arg_error PROTO((void));
extern void S_handle_nonprocedure_symbol PROTO((void));
extern void S_handle_values_error PROTO((void));
extern void S_handle_mvlet_error PROTO((void));
extern void S_handle_event_detour PROTO((void));
extern void S_register_scheme_signal PROTO((iptr sig));
extern void S_fire_collector PROTO((void));
extern NORETURN void S_noncontinuable_interrupt PROTO((void));

1
c/globals.h
View File

@ -117,6 +117,7 @@ EXTERN struct S_G_struct {
ptr nuate_id;
ptr null_continuation_id;
ptr collect_request_pending_id;
ptr event_and_resume_id;
/* gc.c */
ptr guardians[static_generation+1];

1
c/prim.c
View File

@ -135,6 +135,7 @@ static void create_c_entry_vector() {
install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
install_c_entry(CENTRY_handle_event_detour, proc2ptr(S_handle_event_detour));
install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));

20
c/schsig.c
View File

@ -458,6 +458,23 @@ void S_handle_mvlet_error() {
handle_call_error(tc, ERROR_MVLET, Sfalse);
}
void S_handle_event_detour() {
ptr tc = get_thread_context();
ptr resume_proc = CP(tc);
ptr resume_args = Snil;
iptr argcnt, i;
argcnt = (iptr)AC0(tc);
for (i = argcnt; i > 0; i--) {
resume_args = Scons(S_get_scheme_arg(tc, i), resume_args);
}
CP(tc) = S_symbol_value(S_G.event_and_resume_id);
S_put_scheme_arg(tc, 1, resume_proc);
S_put_scheme_arg(tc, 2, resume_args);
AC0(tc) = (ptr)2;
}
static void keyboard_interrupt(ptr tc) {
KEYBOARDINTERRUPTPENDING(tc) = Strue;
SOMETHINGPENDING(tc) = Strue;
@ -692,6 +709,9 @@ void S_schsig_init() {
S_protect(&S_G.error_id);
S_G.error_id = S_intern((const unsigned char *)"$c-error");
S_protect(&S_G.event_and_resume_id);
S_G.event_and_resume_id = S_intern((const unsigned char *)"$event-and-resume");
}

2
makefiles/Mf-install.in
View File

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

4
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x09050311)
(define-constant scheme-version #x09050312)
(define-syntax define-machine-types
(lambda (x)
@ -2555,6 +2555,7 @@
(domvleterr #f 0 #f #f)
(doargerr #f 0 #f #f)
(get-room #f 0 #f #f)
(event-detour #f 0 #f #f)
(map1 #f 2 #f #t)
(map2 #f 3 #f #t)
(for-each1 #f 2 #f #t)
@ -2786,6 +2787,7 @@
handle-values-error
handle-mvlet-error
handle-arg-error
handle-event-detour
foreign-entry
install-library-entry
get-more-room

108
s/cpnanopass.ss
View File

@ -620,6 +620,10 @@
(lambda ()
(make-libspec-label 'call-error (lookup-libspec call-error)
(reg-list %ret %cp))))
(define make-Levent-detour
(lambda ()
(make-libspec-label 'event-detour (lookup-libspec event-detour)
(reg-cons* %ret %cp %ac0 arg-registers))))
(module (frame-vars get-fv)
(define-threaded frame-vars)
@ -10766,29 +10770,22 @@
(tail ,tl)
,(f `(seq (label ,(car l*)) ,(car tl*)) (cdr l*) (cdr tl*)))))]))
(define-pass np-insert-trap-check : L11 (ir) -> L11.5 ()
(Effect : Effect (ir) -> Effect ()
[(trap-check ,ioc)
`(seq
(set! ,(ref-reg %trap) ,(%inline -/eq ,(ref-reg %trap) (immediate 1)))
(if (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)
,(%seq
(pariah)
(mvcall ,(make-info-call #f #f #f #t #f) #f
(literal ,(make-info-literal #f 'library
(if ioc
(lookup-does-not-expect-headroom-libspec event)
(lookup-libspec event))
0))
()))
(nop)))]))
(define-pass np-flatten-case-lambda : L11.5 (ir) -> L12 ()
(define-pass np-flatten-case-lambda : L11 (ir) -> L12 ()
(definitions
(define Ldoargerr (make-Ldoargerr))
(define Ldomvleterr (make-Ldomvleterr))
(define Levent-detour (make-Levent-detour))
(define flatten-clauses
(lambda (info cl* dcl*)
(lambda (info cl* dcl* detour-trap-check?)
(define (maybe-drop-trap-check tl)
(if detour-trap-check?
(nanopass-case (L11 Tail) tl
[(seq (trap-check ,ioc) ,tl) tl]
[(seq (overflow-check) ,tl)
(with-output-language (L11 Tail)
`(seq (overflow-check) ,(maybe-drop-trap-check tl)))]
[else ($oops who "expected trap check at ~s" tl)])
tl))
(let ([libspec (info-lambda-libspec info)])
(with-output-language (L12 Tail)
(when libspec
@ -10803,10 +10800,10 @@
(if (null? cl*)
(values local* (or tlbody (%constant svoid)))
(if (or libspec (direct-call-label-referenced (car dcl*)))
(nanopass-case (L11.5 CaseLambdaClause) (car cl*)
(nanopass-case (L11 CaseLambdaClause) (car cl*)
[(clause (,x* ...) (,local1* ...) ,mcp ,interface ,tlbody1)
(loop (cdr cl*) (cdr dcl*) (maybe-cons mcp (append x* local1* local*))
(let ([tlbody1 `(entry-point (,x* ...) ,(car dcl*) ,mcp ,(Tail tlbody1))])
(let ([tlbody1 `(entry-point (,x* ...) ,(car dcl*) ,mcp ,(Tail (maybe-drop-trap-check tlbody1)))])
(if tlbody
`(seq (tail ,tlbody) ,tlbody1)
tlbody1)))])
@ -10814,9 +10811,9 @@
(let f ([cl* cl*] [dcl* dcl*])
(if (null? cl*)
(values '() `(seq (pariah) (goto ,Ldoargerr)))
(nanopass-case (L11.5 CaseLambdaClause) (car cl*)
(nanopass-case (L11 CaseLambdaClause) (car cl*)
[(clause (,x* ...) (,local* ...) ,mcp ,interface ,tlbody)
(let ([tlbody `(entry-point (,x* ...) ,(car dcl*) ,mcp ,(Tail tlbody))])
(let ([tlbody `(entry-point (,x* ...) ,(car dcl*) ,mcp ,(Tail (maybe-drop-trap-check tlbody)))])
(if (fx< interface 0)
(let ([fixed-args (lognot interface)])
(let ([tlbody (if (uvar-referenced? (list-ref x* fixed-args))
@ -10865,20 +10862,61 @@
`(if ,(%inline eq? ,%ac0
(immediate ,interface))
,ebody
,next-ebody))))))))))
,next-ebody)))))))))
(define (maybe-add-detour-trap-check tl detour-trap-check?)
(if detour-trap-check?
(with-output-language (L12 Tail)
(%seq
(set! ,(ref-reg %trap) ,(%inline -/eq ,(ref-reg %trap) (immediate 1)))
(if (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)
(seq (pariah) (goto ,Levent-detour))
(nop))
,tl))
tl)))
(CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()
[(case-lambda ,info ,cl* ...)
(let-values ([(local* tlbody) (flatten-clauses info cl* (info-lambda-dcl* info))])
(safe-assert (nodups local*))
(info-lambda-dcl*-set! info (filter direct-call-label-referenced (info-lambda-dcl* info)))
`(lambda ,info (,local* ...) ,tlbody))])
(let* ([detour-trap-check? (and (not (info-lambda-libspec info))
(andmap
(lambda (cl dcl)
(and
(not (direct-call-label-referenced dcl))
(nanopass-case (L11 CaseLambdaClause) cl
[(clause (,x* ...) (,local1* ...) ,mcp ,interface ,tlbody)
(let loop ([tlbody tlbody])
(nanopass-case (L11 Tail) tlbody
[(seq (trap-check ,ioc) ,tlbody) #t]
[(seq (overflow-check) ,tlbody) (loop tlbody)]
[else #f]))])))
cl* (info-lambda-dcl* info)))])
(let-values ([(local* tlbody) (flatten-clauses info cl* (info-lambda-dcl* info) detour-trap-check?)])
(safe-assert (nodups local*))
(info-lambda-dcl*-set! info (filter direct-call-label-referenced (info-lambda-dcl* info)))
`(lambda ,info (,local* ...) ,(maybe-add-detour-trap-check tlbody detour-trap-check?))))])
(Tail : Tail (ir) -> Tail ())
(Effect : Effect (ir) -> Effect ()
[(mvset ,info (,mdcl ,[t0?] ,[t1] ...) (,[t*] ...) ((,x** ...) ,interface* ,l*) ...)
`(mvset ,info (,mdcl ,t0? ,t1 ...) (,t* ...) ((,x** ...) ...)
,(flatten-mvclauses x** interface* l*))]))
(define-pass np-impose-calling-conventions : L12 (ir) -> L13 ()
;; converts any `trap-check` effects not lifted out by `np-flatten-case-lambda`
(define-pass np-insert-trap-check : L12 (ir) -> L12.5 ()
(Effect : Effect (ir) -> Effect ()
[(trap-check ,ioc)
`(seq
(set! ,(ref-reg %trap) ,(%inline -/eq ,(ref-reg %trap) (immediate 1)))
(if (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code)
,(%seq
(pariah)
(mvcall ,(make-info-call #f #f #f #t #f) #f
(literal ,(make-info-literal #f 'library
(if ioc
(lookup-does-not-expect-headroom-libspec event)
(lookup-libspec event))
0))
()))
(nop)))]))
(define-pass np-impose-calling-conventions : L12.5 (ir) -> L13 ()
(definitions
(import (only asm-module asm-foreign-call asm-foreign-callable asm-enter))
(define newframe-info-for-mventry-point)
@ -11061,7 +11099,7 @@
(not shift-attachment?))
(direct-call)
(finish-call #f #f (in-context Triv `(label-ref ,mdcl 0)))))
(nanopass-case (L12 Triv) t
(nanopass-case (L12.5 Triv) t
; if the expression in the cp position #f, and we have an mdcl, this is
; a hackish workaround for not having a good way to express maybe-Expr
[(literal ,info)
@ -11112,7 +11150,7 @@
(label ,mrvl))))))
(define store-cp?
(lambda (t)
(nanopass-case (L12 Triv) t
(nanopass-case (L12.5 Triv) t
[(literal ,info) #f]
[else #t])))
(define build-nontail-call
@ -13193,6 +13231,12 @@
[(dooverflood) ((make-do/ret (intrinsic-entry-live* dooverflood) (intrinsic-return-live* dooverflood)) #f "dooverflood" (lookup-c-entry handle-overflood))]
[(scan-remembered-set) ((make-do/ret (intrinsic-entry-live* scan-remembered-set) (intrinsic-return-live* scan-remembered-set)) (in-context Lvalue (%tc-ref ret)) "scan-remembered-set" (lookup-c-entry scan-remembered-set))]
[(get-room) ((make-do/ret (intrinsic-entry-live* get-room) (intrinsic-return-live* get-room)) (in-context Lvalue (%tc-ref ret)) "get-room" (lookup-c-entry get-more-room))]
[(event-detour)
;; Jumping to `event-detour` while arguments are still in place is an alternative
;; to making a normal function call to `$event` (which requires more instructions).
;; Leads to `$event-and-resume`, which calls `$event` and then retries the call
;; that had just started.
(make-do/call (in-context Lvalue (%tc-ref ret)) "event-detour" (lookup-c-entry handle-event-detour))]
[(nonprocedure-code)
`(lambda ,(make-info "nonprocedure-code" '()) 0 ()
,(%seq
@ -17159,8 +17203,8 @@
(pass np-remove-complex-opera* unparse-L10)
(pass np-push-mrvs unparse-L10.5)
(pass np-normalize-context unparse-L11)
(pass np-insert-trap-check unparse-L11.5)
(pass np-flatten-case-lambda unparse-L12)
(pass np-insert-trap-check unparse-L12.5)
(pass np-impose-calling-conventions unparse-L13)
np-after-calling-conventions)))))

1
s/library.ss
View File

@ -133,6 +133,7 @@
(define-hand-coded-library-entry $wrapper-apply)
(define-hand-coded-library-entry wrapper-apply)
(define-hand-coded-library-entry arity-wrapper-apply)
(define-hand-coded-library-entry event-detour)
(define-hand-coded-library-entry popcount-slow) ; before fxpopcount use
(define-hand-coded-library-entry cpu-features) ; before fxpopcount use

18
s/np-languages.ss
View File

@ -49,7 +49,7 @@
L5 unparse-L5 L6 unparse-L6 L7 unparse-L7
L9 unparse-L9 L9.5 unparse-L9.5 L9.75 unparse-L9.75
L10 unparse-L10 L10.5 unparse-L10.5 L11 unparse-L11
L11.5 unparse-L11.5 L12 unparse-L12 L13 unparse-L13 L13.5 unparse-L13.5 L14 unparse-L14
L12 unparse-L12 L12.5 unparse-L12.5 L13 unparse-L13 L13.5 unparse-L13.5 L14 unparse-L14
L15a unparse-L15a L15b unparse-L15b L15c unparse-L15c L15d unparse-L15d
L15e unparse-L15e
L16 unparse-L16
@ -791,14 +791,7 @@
(attachment-set aop t* ...)
(tail tl))))
(define-language L11.5 (extends L11)
(entry Program)
(terminals
(- (boolean (ioc))))
(Effect (e body)
(- (trap-check ioc))))
(define-language L12 (extends L11.5)
(define-language L12 (extends L11)
(terminals
(- (fixnum (interface offset))
(label (l)))
@ -820,6 +813,13 @@
; ideally, grammar would reflect this
(mventry-point (x* ...) l))))
(define-language L12.5 (extends L12)
(entry Program)
(terminals
(- (boolean (ioc))))
(Effect (e ebody)
(- (trap-check ioc))))
(define exact-integer?
(lambda (x)
(and (integer? x) (exact? x))))

1
s/primdata.ss
View File

@ -1874,6 +1874,7 @@
($errno->string [flags single-valued])
($error-handling-mode? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
($event [flags single-valued])
($event-and-resume [flags])
($exactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
($exactnum-imag-part [flags single-valued])
($exactnum-real-part [flags single-valued])

4
s/prims.ss
View File

@ -1558,6 +1558,10 @@
(define $event (lambda () ($event)))
(define $event-and-resume (lambda (proc args)
($event)
(apply proc args)))
(define $tc (lambda () ($tc)))
(define $thread-list (lambda () ($thread-list)))