add support for continuation attachments
original commit: 330ce0bb349965f82e38a7f29fc5d19646f3c246
This commit is contained in:
Matthew Flatt
parent
d3551a0173
commit
73e4ea603f
5
LOG
5
LOG
|
|
@ -991,3 +991,8 @@
|
|||
system.stex, release_notes.stex
|
||||
- fix boot_call and the invoke code object to handle multiple values
|
||||
scheme.c, cpnanopass.ss, 7.ms, release_notes.stex, system.stex
|
||||
- add support for continuation attachments
|
||||
cpnanopass.ss, np-languages.ss, 4.ss, prims.ss, inspect.ss,
|
||||
cmacro.ss, primdata.ss, library.ss types.ss, mkheader.ss,
|
||||
alloc.c, gc.c, schsig.c, thread.c, externs.h,
|
||||
4.ms, control.stex, release_notes.stex
|
||||
|
|
|
|||
|
|
@ -599,9 +599,9 @@ ptr S_closure(cod, n) ptr cod; iptr n; {
|
|||
}
|
||||
|
||||
/* S_mkcontinuation is always called with mutex */
|
||||
ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders)
|
||||
ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders, attachments)
|
||||
ISPC s; IGEN g; ptr nuate; ptr stack; iptr length; iptr clength; ptr link;
|
||||
ptr ret; ptr winders; {
|
||||
ptr ret; ptr winders; ptr attachments; {
|
||||
ptr p;
|
||||
|
||||
find_room(s, g, type_closure, size_continuation, p);
|
||||
|
|
@ -612,6 +612,7 @@ ptr S_mkcontinuation(s, g, nuate, stack, length, clength, link, ret, winders)
|
|||
CONTLINK(p) = link;
|
||||
CONTRET(p) = ret;
|
||||
CONTWINDERS(p) = winders;
|
||||
CONTATTACHMENTS(p) = attachments;
|
||||
return p;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,8 @@ extern ptr S_null_immutable_string PROTO((void));
|
|||
extern ptr S_record PROTO((iptr n));
|
||||
extern ptr S_closure PROTO((ptr cod, iptr n));
|
||||
extern ptr S_mkcontinuation PROTO((ISPC s, IGEN g, ptr nuate, ptr stack,
|
||||
iptr length, iptr clength, ptr link, ptr ret, ptr winders));
|
||||
iptr length, iptr clength, ptr link, ptr ret, ptr winders,
|
||||
ptr attachments));
|
||||
extern ptr S_inexactnum PROTO((double rp, double ip));
|
||||
extern ptr S_exactnum PROTO((ptr a, ptr b));
|
||||
extern ptr S_thread PROTO((ptr tc));
|
||||
|
|
|
|||
3
c/gc.c
3
c/gc.c
|
|
@ -502,6 +502,7 @@ static ptr copy(pp, si) ptr pp; seginfo *si; {
|
|||
CONTLENGTH(p) = CONTLENGTH(pp);
|
||||
CONTCLENGTH(p) = CONTCLENGTH(pp);
|
||||
CONTWINDERS(p) = CONTWINDERS(pp);
|
||||
CONTATTACHMENTS(p) = CONTATTACHMENTS(pp);
|
||||
if (CONTLENGTH(p) != scaled_shot_1_shot_flag) {
|
||||
CONTLINK(p) = CONTLINK(pp);
|
||||
CONTRET(p) = CONTRET(pp);
|
||||
|
|
@ -1469,6 +1470,7 @@ static void sweep_thread(p) ptr p; {
|
|||
relocate(&STACKLINK(tc))
|
||||
/* iptr SCHEMESTACKSIZE */
|
||||
relocate(&WINDERS(tc))
|
||||
relocate(&ATTACHMENTS(tc))
|
||||
relocate_return_addr(&FRAME(tc,0))
|
||||
sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0));
|
||||
relocate(&U(tc))
|
||||
|
|
@ -1515,6 +1517,7 @@ static void sweep_thread(p) ptr p; {
|
|||
|
||||
static void sweep_continuation(p) ptr p; {
|
||||
relocate(&CONTWINDERS(p))
|
||||
relocate(&CONTATTACHMENTS(p))
|
||||
|
||||
/* bug out for shot 1-shot continuations */
|
||||
if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return;
|
||||
|
|
|
|||
|
|
@ -65,7 +65,8 @@ static void split(k, s) ptr k; ptr *s; {
|
|||
m, m,
|
||||
CONTLINK(k),
|
||||
*s,
|
||||
Snil);
|
||||
Snil,
|
||||
Sfalse);
|
||||
CONTLENGTH(k) = CONTCLENGTH(k) = n;
|
||||
CONTSTACK(k) = (ptr)s;
|
||||
*s = (ptr)DOUNDERFLOW;
|
||||
|
|
@ -279,7 +280,8 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; {
|
|||
split_stack_clength,
|
||||
STACKLINK(tc),
|
||||
*split_point,
|
||||
Snil);
|
||||
Snil,
|
||||
Sfalse);
|
||||
tc_mutex_release()
|
||||
|
||||
/* overwrite old return address with dounderflow */
|
||||
|
|
@ -686,7 +688,8 @@ void S_schsig_init() {
|
|||
scaled_shot_1_shot_flag, scaled_shot_1_shot_flag,
|
||||
FIX(0),
|
||||
FIX(0),
|
||||
Snil));
|
||||
Snil,
|
||||
Sfalse));
|
||||
|
||||
S_protect(&S_G.error_id);
|
||||
S_G.error_id = S_intern((const unsigned char *)"$c-error");
|
||||
|
|
|
|||
|
|
@ -80,6 +80,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
|
|||
CCHAIN(tc) = Snil;
|
||||
|
||||
WINDERS(tc) = Snil;
|
||||
ATTACHMENTS(tc) = Snil;
|
||||
STACKLINK(tc) = SYMVAL(S_G.null_continuation_id);
|
||||
STACKCACHE(tc) = Snil;
|
||||
|
||||
|
|
|
|||
|
|
@ -208,6 +208,18 @@ One-shot continuations are continuations that may be invoked at most
|
|||
once, whether explicitly or implicitly.
|
||||
They are obtained with \scheme{call/1cc}.
|
||||
|
||||
Continuation \textit{attachment}s support efficient annotation and
|
||||
inspection of continuations. Each continution has either one immediate
|
||||
attachment or none, and an immediate attachment is added or replaced
|
||||
using \scheme{call-setting-continuation-attachment}. The
|
||||
\scheme{call-with-current-continuation-attachment} function retrieves
|
||||
the current continuation's attachment, if any. Although each
|
||||
continuation has a single immediate attachment, a continuation may
|
||||
extend another continuation that has its own separate attachment, and
|
||||
the \scheme{current-continuation-attachments} function returns a list
|
||||
of attachments for the current continuation and all continuations that
|
||||
it extends.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{call/1cc}{\categoryprocedure}{(call/1cc \var{procedure})}
|
||||
|
|
@ -293,6 +305,132 @@ Extreme caution must be taken with this form of \scheme{dynamic-wind},
|
|||
since an error or long-running computation can leave interrupts
|
||||
and automatic garbage collection disabled.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader\label{call-setting-continuation-attachment}\label{call-with-current-continuation-attachment}
|
||||
\formdef{call-setting-continuation-attachment}{\categoryprocedure}{(call-setting-continuation-attachment \var{val} \var{procedure})}
|
||||
\formdef{call-with-current-continuation-attachment}{\categoryprocedure}{(call-with-current-continuation-attachment \var{default-val} \var{procedure})}
|
||||
\returns the values returned by \var{procedure}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent \scheme{call-setting-continuation-attachment} calls
|
||||
\var{procedure} with no arguments while setting the attachment of the
|
||||
current continuation to \var{val}. The continuation of the call to
|
||||
\var{procedure} is the same as the continuation of the call to
|
||||
\scheme{call-setting-continuation-attachment} (i.e., it is still the
|
||||
current continuation). If the current continuation already has an
|
||||
attachment, it is replaced by \var{val}.
|
||||
|
||||
\scheme{call-with-current-continuation-attachment} calls
|
||||
\var{procedure} with one argument: the current continuation's
|
||||
attachment, if any, or the value of \var{default-val} if the current
|
||||
continuation has no attachment. The continuation of the call to
|
||||
\var{procedure} is the same as the continuation of the call to
|
||||
\scheme{call-with-current-continuation-attachment} (i.e., it is still
|
||||
the current continuation).
|
||||
|
||||
\schemedisplay
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))) ; => milk
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a))))) ; => (nothing)
|
||||
|
||||
(list
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a))))) ; => (milk)
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-setting-continuation-attachment
|
||||
'water
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))))) ; => water
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader\label{current-continuation-attachments}
|
||||
\formdef{current-continuation-attachments}{\categoryprocedure}{(current-continuation-attachments)}
|
||||
\returns a list
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent \scheme{current-continuation-attachments} returns a list of
|
||||
attachments starting with the current continuation's attachment, if
|
||||
any, followed by the attachment of continuation that is extended by
|
||||
the current continuation, and so on. If a continuation has no
|
||||
attachment, then no corresponding element is included in the result
|
||||
list.
|
||||
|
||||
\schemedisplay
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(current-continuation-attachments))) ; => (milk)
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(vector
|
||||
(call-setting-continuation-attachment
|
||||
'cookies
|
||||
(lambda ()
|
||||
(current-continuation-attachments)))))) ; => #((cookies milk))
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-setting-continuation-attachment
|
||||
'water
|
||||
(lambda ()
|
||||
(current-continuation-attachments))))) ; => (water)
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader\label{continuation-next-attachments}
|
||||
\formdef{continuation-next-attachments}{\categoryprocedure}{(continuation-next-attachments \var{continuation})}
|
||||
\returns a list
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent \scheme{continuation-next-attachments} takes a continuation
|
||||
and returns the list of attachments that
|
||||
\scheme{current-continuation-attachments} would return if it were
|
||||
called as the next step of \var{continuation}. Note that the result
|
||||
list will not include any attachment on the immediate continuation
|
||||
that is captured by \var{continuation}---only the attachments of continuations
|
||||
that are extended by \var{continuation}.
|
||||
|
||||
\schemedisplay
|
||||
(define about-to-snack
|
||||
(call/cc
|
||||
(lambda (esc)
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(snack (call-setting-continuation-attachment
|
||||
'cookies
|
||||
(lambda () (call/cc esc)))))))))
|
||||
|
||||
(continuation-next-attachments about-to-snack) ; => (milk)
|
||||
\endschemedisplay
|
||||
|
||||
\section{Engines\label{SECTENGINES}}
|
||||
|
||||
\index{engines}Engines are a high-level process abstraction supporting
|
||||
|
|
|
|||
250
mats/4.ms
250
mats/4.ms
|
|
@ -3177,6 +3177,256 @@
|
|||
"EIEIO")
|
||||
)
|
||||
|
||||
(mat continuation-attachments
|
||||
(error? (current-continuation-attachments '()))
|
||||
|
||||
(error? (call-setting-continuation-attachment 'any))
|
||||
(error? (call-setting-continuation-attachment 'any 10))
|
||||
(error? (call-setting-continuation-attachment 'any void 'bad-more))
|
||||
(error? (call-setting-continuation-attachment 'any (lambda (x) x)))
|
||||
|
||||
(error? (call-with-current-continuation-attachment 'none))
|
||||
(error? (call-with-current-continuation-attachment 'none 10))
|
||||
(error? (call-with-current-continuation-attachment 'none (lambda (a) a) 'bad-more))
|
||||
(error? (call-with-current-continuation-attachment 'none void))
|
||||
|
||||
(error? (continuation-next-attachments))
|
||||
(error? (continuation-next-attachments 10))
|
||||
(error? (continuation-next-attachments (lambda (x) x)))
|
||||
(error? (continuation-next-attachments (call/cc (lambda (x) x)) 'bad-more))
|
||||
|
||||
(equal? (void) (call-setting-continuation-attachment 'any void))
|
||||
(equal? 'none (call-with-current-continuation-attachment 'none (lambda (a) a)))
|
||||
(equal? '() (continuation-next-attachments (call/cc (lambda (x) x))))
|
||||
|
||||
(equal? '() (current-continuation-attachments))
|
||||
(equal? '(#&(1 2 3))
|
||||
(call-setting-continuation-attachment
|
||||
3
|
||||
(lambda ()
|
||||
(list
|
||||
(call-setting-continuation-attachment
|
||||
2
|
||||
(lambda ()
|
||||
(box
|
||||
(call-setting-continuation-attachment
|
||||
1
|
||||
(lambda ()
|
||||
(current-continuation-attachments))))))))))
|
||||
(equal? '() (current-continuation-attachments))
|
||||
(equal? '#((left) (right))
|
||||
(vector (call-setting-continuation-attachment
|
||||
'left
|
||||
(lambda () (current-continuation-attachments)))
|
||||
(call-setting-continuation-attachment
|
||||
'right
|
||||
(lambda () (current-continuation-attachments)))))
|
||||
(equal? '#((left2) (right2))
|
||||
(vector (call-setting-continuation-attachment
|
||||
'left2
|
||||
current-continuation-attachments)
|
||||
(call-setting-continuation-attachment
|
||||
'right2
|
||||
current-continuation-attachments)))
|
||||
(equal? 'yes
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v)))))
|
||||
(equal? 'yes
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
'no
|
||||
values))))
|
||||
(equal? '(no)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v))))))
|
||||
(equal? '(no)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
'no
|
||||
values)))))
|
||||
(begin
|
||||
(define (call-with-yep f)
|
||||
(call-setting-continuation-attachment
|
||||
'yep
|
||||
(lambda () (f))))
|
||||
(define (call-with-yeah f)
|
||||
(call-setting-continuation-attachment
|
||||
'yeah
|
||||
f))
|
||||
(define-syntax call-with-yeah*
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
(call-setting-continuation-attachment
|
||||
'yeah
|
||||
f)]))
|
||||
(define (get-or-nope)
|
||||
(call-with-current-continuation-attachment
|
||||
'nope
|
||||
(lambda (x) x)))
|
||||
(define (return-one) 1)
|
||||
(define (act-like-list . l) l)
|
||||
(define not-a-procedure 'something-else)
|
||||
(define (returns-not-a-procedure) 'also-something-else)
|
||||
(define (return-three-values) (values 1 2 3))
|
||||
(define (return-the-same-value v) v)
|
||||
#t)
|
||||
(equal? 'yep (call-with-yep get-or-nope))
|
||||
(equal? 'yeah (call-with-yep (lambda () (call-with-yeah get-or-nope))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (call-with-yeah current-continuation-attachments))))
|
||||
(equal? '((yeah yep)) (call-with-yep (lambda () (list (call-with-yeah current-continuation-attachments)))))
|
||||
(equal? '((yeah yep)) (call-with-yep (lambda () (act-like-list (call-with-yeah current-continuation-attachments)))))
|
||||
(equal? '(yeah yep) (call-with-yep (lambda () (let ([v #f])
|
||||
(set! v (call-with-yeah current-continuation-attachments))
|
||||
v))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (list (get-or-nope)))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (act-like-list (get-or-nope)))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (list (get-or-nope)))))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (act-like-list (get-or-nope)))))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah (lambda () (get-or-nope)))))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah (lambda () (get-or-nope)))))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (list (get-or-nope)))))))
|
||||
(equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (act-like-list (get-or-nope)))))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah* (lambda () (get-or-nope)))))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (get-or-nope)))))))
|
||||
|
||||
(error? (call-with-yep (lambda () (call-with-yeah* (lambda () (not-a-procedure))))))
|
||||
(error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () (not-a-procedure)))))))
|
||||
(error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (not-a-procedure)))))))
|
||||
(error? (call-with-yep (lambda () (call-with-yeah* (lambda () ((returns-not-a-procedure)))))))
|
||||
(error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
|
||||
(error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
|
||||
|
||||
(equal? '() (if (call-with-yep list)
|
||||
(current-continuation-attachments)
|
||||
#f))
|
||||
(equal? '() (if (call-setting-continuation-attachment 'here (lambda () #t))
|
||||
(current-continuation-attachments)
|
||||
#f))
|
||||
(equal? 1 (let loop ([i 10000])
|
||||
(if (zero? i)
|
||||
(length (current-continuation-attachments))
|
||||
(call-setting-continuation-attachment
|
||||
'here
|
||||
(lambda ()
|
||||
(loop (sub1 i)))))))
|
||||
(equal? 10000 (let loop ([i 10000])
|
||||
(if (zero? i)
|
||||
(length (current-continuation-attachments))
|
||||
(call-setting-continuation-attachment
|
||||
'here
|
||||
(lambda ()
|
||||
(return-the-same-value (loop (sub1 i))))))))
|
||||
(equal? '#((forget-me yeah yep) (yeah yep))
|
||||
(call/cc
|
||||
(lambda (esc)
|
||||
(call-with-yep
|
||||
(lambda ()
|
||||
(list (call-with-yeah
|
||||
(lambda ()
|
||||
(list (call-setting-continuation-attachment
|
||||
'forget-me
|
||||
(lambda ()
|
||||
(call/cc
|
||||
(lambda (k)
|
||||
(esc (vector
|
||||
(current-continuation-attachments)
|
||||
(continuation-next-attachments k))))))))))))))))
|
||||
(equal? '#(((yep) (yep))
|
||||
((yeah yep))
|
||||
((yep) (yep)))
|
||||
(let ([pre '()]
|
||||
[body '()]
|
||||
[post '()])
|
||||
((call/cc
|
||||
(lambda (esc)
|
||||
(call-with-yep
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! pre (cons (current-continuation-attachments) pre)))
|
||||
(lambda ()
|
||||
(call-with-yeah
|
||||
(lambda ()
|
||||
((call/cc
|
||||
(lambda (retry)
|
||||
(set! body (cons (current-continuation-attachments) body))
|
||||
(esc retry)))))))
|
||||
(lambda ()
|
||||
(set! post (cons (current-continuation-attachments) post))))))))
|
||||
(lambda () (lambda (self) void)))
|
||||
(vector pre body post)))
|
||||
|
||||
(equal? 'ok
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
(call-with-values (lambda () (return-three-values))
|
||||
(case-lambda
|
||||
[(x y z)
|
||||
(get-or-nope)])))))
|
||||
(equal? '(ok 1 2 3)
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
(call-with-values (lambda () (return-three-values))
|
||||
(case-lambda
|
||||
[(x y z)
|
||||
(call-with-current-continuation-attachment
|
||||
'nope
|
||||
(lambda (a) (list a x y z)))])))))
|
||||
|
||||
;; intended to trigger `mvcall` in the `np-recognize-attachment` pass:
|
||||
(equal? '(1)
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
(call-with-values (lambda () (return-one)) act-like-list))))
|
||||
(equal? '(1)
|
||||
(letrec ([act-like-list (lambda l
|
||||
(if (equal? l '(never))
|
||||
(act-like-list (cdr l))
|
||||
l))])
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
;; `call-with-values` can see that `act-like-list` has
|
||||
;; a rest argument, and it generates a direct call
|
||||
(call-with-values (lambda () (return-one)) act-like-list)))))
|
||||
(equal? '(1)
|
||||
;; Like the previous example, but in tail position
|
||||
(call-with-yep ; just to ensure the argument `lambda` isn't inlined
|
||||
(lambda ()
|
||||
(letrec ([act-like-list (lambda l
|
||||
(if (equal? l '(never))
|
||||
(act-like-list (cdr l))
|
||||
l))])
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
(call-with-values (lambda () (return-one)) act-like-list)))))))
|
||||
(equal? '(1)
|
||||
(call-with-yep ; just to ensure the argument `lambda` isn't inlined
|
||||
(lambda ()
|
||||
(call-setting-continuation-attachment
|
||||
'ok
|
||||
(lambda ()
|
||||
(call-with-values (lambda () (return-one)) act-like-list))))))
|
||||
)
|
||||
|
||||
;;; section 4-7:
|
||||
|
||||
(mat engine
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
*** errors-compile-0-f-f-f 2018-07-17 17:57:31.932340347 -0400
|
||||
--- errors-compile-0-f-t-f 2018-07-17 17:05:48.812444920 -0400
|
||||
*** errors-compile-0-f-f-f 2018-07-24 22:17:12.000000000 -0600
|
||||
--- errors-compile-0-f-t-f 2018-07-24 21:07:12.000000000 -0600
|
||||
***************
|
||||
*** 125,131 ****
|
||||
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
|
||||
|
|
@ -58,7 +58,7 @@
|
|||
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
|
||||
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
|
||||
***************
|
||||
*** 3697,3703 ****
|
||||
*** 3716,3722 ****
|
||||
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
|
||||
|
|
@ -66,7 +66,7 @@
|
|||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
|
||||
--- 3697,3703 ----
|
||||
--- 3716,3722 ----
|
||||
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
|
||||
|
|
@ -75,7 +75,7 @@
|
|||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
|
||||
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
|
||||
***************
|
||||
*** 7161,7168 ****
|
||||
*** 7180,7187 ****
|
||||
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
|
||||
7.mo:Expected error in mat error: "a: hit me!".
|
||||
7.mo:Expected error in mat error: "f: n is 0".
|
||||
|
|
@ -84,7 +84,7 @@
|
|||
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
|
||||
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
|
||||
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
|
||||
--- 7161,7168 ----
|
||||
--- 7180,7187 ----
|
||||
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
|
||||
7.mo:Expected error in mat error: "a: hit me!".
|
||||
7.mo:Expected error in mat error: "f: n is 0".
|
||||
|
|
@ -94,7 +94,7 @@
|
|||
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
|
||||
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
|
||||
***************
|
||||
*** 7170,7184 ****
|
||||
*** 7189,7203 ****
|
||||
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
|
||||
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
|
||||
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
|
||||
|
|
@ -110,7 +110,7 @@
|
|||
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
--- 7170,7184 ----
|
||||
--- 7189,7203 ----
|
||||
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
|
||||
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
|
||||
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
|
||||
|
|
@ -127,7 +127,7 @@
|
|||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
***************
|
||||
*** 7191,7216 ****
|
||||
*** 7210,7235 ****
|
||||
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
|
|
@ -154,7 +154,7 @@
|
|||
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
|
||||
--- 7191,7216 ----
|
||||
--- 7210,7235 ----
|
||||
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
|
|
@ -182,7 +182,7 @@
|
|||
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
|
||||
***************
|
||||
*** 7341,7379 ****
|
||||
*** 7360,7398 ****
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
|
||||
|
|
@ -222,7 +222,7 @@
|
|||
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
|
||||
--- 7341,7379 ----
|
||||
--- 7360,7398 ----
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
|
||||
|
|
@ -263,7 +263,7 @@
|
|||
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
|
||||
***************
|
||||
*** 7388,7444 ****
|
||||
*** 7407,7463 ****
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
|
||||
|
|
@ -321,7 +321,7 @@
|
|||
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
|
||||
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
|
||||
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
|
||||
--- 7388,7444 ----
|
||||
--- 7407,7463 ----
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,5 +1,5 @@
|
|||
*** errors-compile-0-f-f-f 2018-07-17 17:57:31.932340347 -0400
|
||||
--- errors-interpret-0-f-f-f 2018-07-17 17:26:13.772403640 -0400
|
||||
*** errors-compile-0-f-f-f 2018-07-24 22:17:12.000000000 -0600
|
||||
--- errors-interpret-0-f-f-f 2018-07-24 21:35:45.000000000 -0600
|
||||
***************
|
||||
*** 1,7 ****
|
||||
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
|
||||
|
|
@ -196,7 +196,7 @@
|
|||
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
|
||||
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
|
||||
***************
|
||||
*** 4069,4084 ****
|
||||
*** 4088,4103 ****
|
||||
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
|
||||
|
|
@ -213,9 +213,9 @@
|
|||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
|
||||
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
|
||||
--- 4075,4084 ----
|
||||
--- 4094,4103 ----
|
||||
***************
|
||||
*** 7024,7030 ****
|
||||
*** 7043,7049 ****
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
|
||||
|
|
@ -223,7 +223,7 @@
|
|||
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
|
||||
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
|
||||
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
|
||||
--- 7024,7030 ----
|
||||
--- 7043,7049 ----
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
|
||||
|
|
@ -232,7 +232,7 @@
|
|||
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
|
||||
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
|
||||
***************
|
||||
*** 7352,7358 ****
|
||||
*** 7371,7377 ****
|
||||
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
|
||||
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
|
||||
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
|
||||
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
|
||||
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
|
||||
--- 7352,7358 ----
|
||||
--- 7371,7377 ----
|
||||
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
|
||||
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
|
||||
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
|
||||
|
|
@ -249,7 +249,7 @@
|
|||
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
|
||||
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
|
||||
***************
|
||||
*** 8569,8581 ****
|
||||
*** 8588,8600 ****
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
|
||||
|
|
@ -263,7 +263,7 @@
|
|||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
|
||||
--- 8569,8581 ----
|
||||
--- 8588,8600 ----
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
|
||||
|
|
@ -278,7 +278,7 @@
|
|||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
|
||||
***************
|
||||
*** 9336,9360 ****
|
||||
*** 9355,9379 ****
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
|
|
@ -304,7 +304,7 @@
|
|||
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
|
||||
--- 9336,9360 ----
|
||||
--- 9355,9379 ----
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
|
||||
|
|
@ -331,7 +331,7 @@
|
|||
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
|
||||
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
|
||||
***************
|
||||
*** 9367,9398 ****
|
||||
*** 9386,9417 ****
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
|
||||
|
|
@ -364,7 +364,7 @@
|
|||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
--- 9367,9398 ----
|
||||
--- 9386,9417 ----
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
|
||||
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
|
||||
|
|
@ -398,7 +398,7 @@
|
|||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
***************
|
||||
*** 9400,9425 ****
|
||||
*** 9419,9444 ****
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
|
|
@ -425,7 +425,7 @@
|
|||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
--- 9400,9425 ----
|
||||
--- 9419,9444 ----
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
|
||||
|
|
@ -453,7 +453,7 @@
|
|||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
***************
|
||||
*** 9430,9464 ****
|
||||
*** 9449,9483 ****
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
|
|
@ -489,7 +489,7 @@
|
|||
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
|
||||
--- 9430,9464 ----
|
||||
--- 9449,9483 ----
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
|
|
@ -526,7 +526,7 @@
|
|||
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
|
||||
***************
|
||||
*** 10065,10074 ****
|
||||
*** 10084,10093 ****
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
|
||||
|
|
@ -537,7 +537,7 @@
|
|||
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
|
||||
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
|
||||
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
|
||||
--- 10065,10074 ----
|
||||
--- 10084,10093 ----
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
*** errors-compile-0-f-t-f 2018-07-17 17:05:48.812444920 -0400
|
||||
--- errors-interpret-0-f-t-f 2018-07-17 17:36:49.080382231 -0400
|
||||
*** errors-compile-0-f-t-f 2018-07-24 21:07:12.000000000 -0600
|
||||
--- errors-interpret-0-f-t-f 2018-07-24 21:50:02.000000000 -0600
|
||||
***************
|
||||
*** 1,7 ****
|
||||
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
|
||||
|
|
@ -169,7 +169,7 @@
|
|||
3.mo:Expected error in mat letrec: "variable f is not bound".
|
||||
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
|
||||
***************
|
||||
*** 4069,4084 ****
|
||||
*** 4088,4103 ****
|
||||
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
|
||||
|
|
@ -186,9 +186,9 @@
|
|||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
|
||||
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
|
||||
--- 4075,4084 ----
|
||||
--- 4094,4103 ----
|
||||
***************
|
||||
*** 7024,7030 ****
|
||||
*** 7043,7049 ****
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
|
||||
|
|
@ -196,7 +196,7 @@
|
|||
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
|
||||
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
|
||||
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
|
||||
--- 7024,7030 ----
|
||||
--- 7043,7049 ----
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
|
||||
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
|
||||
|
|
@ -205,7 +205,7 @@
|
|||
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
|
||||
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
|
||||
***************
|
||||
*** 7161,7168 ****
|
||||
*** 7180,7187 ****
|
||||
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
|
||||
7.mo:Expected error in mat error: "a: hit me!".
|
||||
7.mo:Expected error in mat error: "f: n is 0".
|
||||
|
|
@ -214,7 +214,7 @@
|
|||
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
|
||||
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
|
||||
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
|
||||
--- 7161,7168 ----
|
||||
--- 7180,7187 ----
|
||||
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
|
||||
7.mo:Expected error in mat error: "a: hit me!".
|
||||
7.mo:Expected error in mat error: "f: n is 0".
|
||||
|
|
@ -224,7 +224,7 @@
|
|||
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
|
||||
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
|
||||
***************
|
||||
*** 7170,7184 ****
|
||||
*** 7189,7203 ****
|
||||
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
|
||||
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
|
||||
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
--- 7170,7184 ----
|
||||
--- 7189,7203 ----
|
||||
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
|
||||
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
|
||||
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
|
||||
|
|
@ -257,7 +257,7 @@
|
|||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
|
||||
***************
|
||||
*** 7191,7216 ****
|
||||
*** 7210,7235 ****
|
||||
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
|
|
@ -284,7 +284,7 @@
|
|||
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
|
||||
--- 7191,7216 ----
|
||||
--- 7210,7235 ----
|
||||
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
|
||||
|
|
@ -312,7 +312,7 @@
|
|||
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
|
||||
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
|
||||
***************
|
||||
*** 7341,7379 ****
|
||||
*** 7360,7398 ****
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
|
||||
|
|
@ -352,7 +352,7 @@
|
|||
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
|
||||
--- 7341,7379 ----
|
||||
--- 7360,7398 ----
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
|
||||
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
|
||||
|
|
@ -393,7 +393,7 @@
|
|||
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
|
||||
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
|
||||
***************
|
||||
*** 7388,7444 ****
|
||||
*** 7407,7463 ****
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
|
||||
|
|
@ -451,7 +451,7 @@
|
|||
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
|
||||
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
|
||||
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
|
||||
--- 7388,7444 ----
|
||||
--- 7407,7463 ----
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
|
||||
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
|
||||
|
|
@ -510,7 +510,7 @@
|
|||
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
|
||||
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
|
||||
***************
|
||||
*** 8569,8581 ****
|
||||
*** 8588,8600 ****
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
|
||||
|
|
@ -524,7 +524,7 @@
|
|||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
|
||||
--- 8569,8581 ----
|
||||
--- 8588,8600 ----
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
|
||||
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
|
||||
|
|
@ -539,7 +539,7 @@
|
|||
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
|
||||
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
|
||||
***************
|
||||
*** 10065,10074 ****
|
||||
*** 10084,10093 ****
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
|
||||
|
|
@ -550,7 +550,7 @@
|
|||
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
|
||||
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
|
||||
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
|
||||
--- 10065,10074 ----
|
||||
--- 10084,10093 ----
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
|
||||
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
*** errors-compile-3-f-f-f 2018-05-21 15:41:36.322395203 -0400
|
||||
--- errors-interpret-3-f-f-f 2018-05-21 16:32:29.625426575 -0400
|
||||
*** errors-compile-3-f-f-f 2018-07-24 21:00:04.000000000 -0600
|
||||
--- errors-interpret-3-f-f-f 2018-07-24 22:34:46.000000000 -0600
|
||||
***************
|
||||
*** 1,3 ****
|
||||
--- 1,9 ----
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
*** errors-compile-3-f-t-f 2018-05-21 15:49:28.816472990 -0400
|
||||
--- errors-interpret-3-f-t-f 2018-05-21 16:15:47.611381258 -0400
|
||||
*** errors-compile-3-f-t-f 2018-07-24 21:14:04.000000000 -0600
|
||||
--- errors-interpret-3-f-t-f 2018-07-24 21:57:03.000000000 -0600
|
||||
***************
|
||||
*** 1,3 ****
|
||||
--- 1,9 ----
|
||||
|
|
|
|||
|
|
@ -527,6 +527,25 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
|
|||
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
|
||||
4.mo:Expected error in mat dynamic-wind: "variable gook is not bound".
|
||||
4.mo:Expected error in mat call/1cc: "attempt to invoke shot one-shot continuation".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (current-continuation-attachments (quote ()))".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-setting-continuation-attachment (quote any))".
|
||||
4.mo:Expected error in mat continuation-attachments: "call-setting-continuation-attachment: 10 is not a procedure".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-setting-continuation-attachment (quote any) void (quote bad-more))".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect number of arguments to #<procedure>".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-with-current-continuation-attachment (quote none))".
|
||||
4.mo:Expected error in mat continuation-attachments: "call-with-current-continuation-attachment: 10 is not a procedure".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (call-with-current-continuation-attachment (quote none) (lambda (a) a) (quote bad-more))".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect number of arguments to #<procedure void>".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (continuation-next-attachments)".
|
||||
4.mo:Expected error in mat continuation-attachments: "continuation-next-attachments: 10 is not a continuation".
|
||||
4.mo:Expected error in mat continuation-attachments: "continuation-next-attachments: #<procedure> is not a continuation".
|
||||
4.mo:Expected error in mat continuation-attachments: "incorrect argument count in call (continuation-next-attachments (call/cc (lambda (...) x)) (quote bad-more))".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure something-else".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
|
||||
4.mo:Expected error in mat continuation-attachments: "attempt to apply non-procedure also-something-else".
|
||||
4.mo:Expected error in mat $primitive: "fx+: a is not a fixnum".
|
||||
4.mo:Expected error in mat $primitive: "invalid primitive name fubar".
|
||||
4.mo:Expected error in mat $primitive: "incorrect argument count in call (car (quote a) (quote b))".
|
||||
|
|
|
|||
|
|
@ -58,6 +58,15 @@ Online versions of both books can be found at
|
|||
%-----------------------------------------------------------------------------
|
||||
\section{Functionality Changes}\label{section:functionality}
|
||||
|
||||
\subsection{Continuation attachments (9.5.1)}
|
||||
|
||||
The new \scheme{call-setting-continuation-attachment},
|
||||
\scheme{call-with-current-continuation-attachment}, and
|
||||
\scheme{current-continuation-attachments} procedure support
|
||||
efficiently recording and querying information on a continuation, but
|
||||
without unnecessarily extending continuation---that is, without
|
||||
interfering with tail-call behavior.
|
||||
|
||||
\subsection{Procedure source location without inspector information (9.5.1)}
|
||||
|
||||
When \scheme{generate-inspector-information} is set to \scheme{#f} and
|
||||
|
|
|
|||
26
s/4.ss
26
s/4.ss
|
|
@ -281,13 +281,16 @@
|
|||
(map car more)))))]))
|
||||
)
|
||||
|
||||
|
||||
(let ()
|
||||
(define disable/enable (make-winder #f disable-interrupts enable-interrupts))
|
||||
(include "types.ss")
|
||||
|
||||
(define disable/enable (make-winder disable-interrupts enable-interrupts '()))
|
||||
|
||||
(define (dwind in body out)
|
||||
(let ((old-winders ($current-winders)))
|
||||
(in)
|
||||
($current-winders (cons (make-winder #f in out) old-winders))
|
||||
($current-winders (cons (make-winder in out ($current-attachments)) old-winders))
|
||||
(call-with-values
|
||||
body
|
||||
(case-lambda
|
||||
|
|
@ -306,7 +309,7 @@
|
|||
(disable-interrupts)
|
||||
($current-winders d/e+old-winders)
|
||||
(in)
|
||||
($current-winders (cons (make-winder #t in out) old-winders))
|
||||
($current-winders (cons (make-critical-winder in out ($current-attachments)) old-winders))
|
||||
(enable-interrupts)
|
||||
(call-with-values
|
||||
body
|
||||
|
|
@ -361,33 +364,46 @@
|
|||
(let f ((old old))
|
||||
(unless (eq? old tail)
|
||||
(let ([w (car old)] [old (cdr old)])
|
||||
(if (winder-critical? w)
|
||||
(if (critical-winder? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable old))
|
||||
($current-attachments (winder-attachments w))
|
||||
((winder-out w))
|
||||
($current-winders old)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
($current-winders old)
|
||||
($current-attachments (winder-attachments w))
|
||||
((winder-out w))))
|
||||
(f old))))
|
||||
(let f ([new new])
|
||||
(unless (eq? new tail)
|
||||
(let ([w (car new)])
|
||||
(f (cdr new))
|
||||
(if (winder-critical? w)
|
||||
(if (critical-winder? w)
|
||||
(begin
|
||||
(disable-interrupts)
|
||||
($current-winders (cons disable/enable (cdr new)))
|
||||
($current-attachments (winder-attachments w))
|
||||
((winder-in w))
|
||||
($current-winders new)
|
||||
(enable-interrupts))
|
||||
(begin
|
||||
($current-attachments (winder-attachments w))
|
||||
((winder-in w))
|
||||
($current-winders new)))))))))
|
||||
)
|
||||
|
||||
(define current-continuation-attachments
|
||||
(lambda ()
|
||||
($current-attachments)))
|
||||
|
||||
(define-who continuation-next-attachments
|
||||
(lambda (c)
|
||||
(unless ($continuation? c)
|
||||
($oops who "~s is not a continuation" c))
|
||||
($continuation-attachments c)))
|
||||
|
||||
;;; make-promise and force
|
||||
|
||||
|
|
|
|||
23
s/cmacros.ss
23
s/cmacros.ss
|
|
@ -1296,7 +1296,8 @@
|
|||
[iptr stack-clength]
|
||||
[ptr link]
|
||||
[ptr return-address]
|
||||
[ptr winders]))
|
||||
[ptr winders]
|
||||
[ptr attachments])) ; #f => not recorded
|
||||
|
||||
(define-primitive-structure-disps record type-typed-object
|
||||
([ptr type]
|
||||
|
|
@ -1335,6 +1336,7 @@
|
|||
[ptr stack-link]
|
||||
[iptr scheme-stack-size]
|
||||
[ptr winders]
|
||||
[ptr attachments]
|
||||
[ptr U]
|
||||
[ptr V]
|
||||
[ptr W]
|
||||
|
|
@ -1880,23 +1882,6 @@
|
|||
(define-constant time-collector-cpu 5)
|
||||
(define-constant time-collector-real 6)
|
||||
|
||||
(define-syntax make-winder
|
||||
(syntax-rules ()
|
||||
[(_ critical? in out) (vector critical? in out)]))
|
||||
(define-syntax winder-critical? (syntax-rules () [(_ w) (vector-ref w 0)]))
|
||||
(define-syntax winder-in (syntax-rules () [(_ w) (vector-ref w 1)]))
|
||||
(define-syntax winder-out (syntax-rules () [(_ w) (vector-ref w 2)]))
|
||||
|
||||
(define-syntax winder?
|
||||
(syntax-rules ()
|
||||
[(_ ?w)
|
||||
(let ([w ?w])
|
||||
(and (vector? w)
|
||||
(fx= (vector-length w) 3)
|
||||
(boolean? (winder-critical? w))
|
||||
(procedure? (winder-in w))
|
||||
(procedure? (winder-out w))))]))
|
||||
|
||||
(define-syntax default-run-cp0
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
@ -2566,6 +2551,7 @@
|
|||
(ormap1 #f 2 #f #t)
|
||||
(put-bytevector-some #f 4 #f #t)
|
||||
(put-string-some #f 4 #f #t)
|
||||
(reify-cc #f 0 #f #f)
|
||||
(dofretu8* #f 1 #f #f)
|
||||
(dofretu16* #f 1 #f #f)
|
||||
(dofretu32* #f 1 #f #f)
|
||||
|
|
@ -2600,6 +2586,7 @@
|
|||
(nuate #f 0 #f #t)
|
||||
(virtual-register #f 1 #t #t)
|
||||
(set-virtual-register! #f 1 #t #t)
|
||||
($shift-attachment #f 0 #f #f)
|
||||
))
|
||||
|
||||
(let ()
|
||||
|
|
|
|||
404
s/cpnanopass.ss
404
s/cpnanopass.ss
|
|
@ -903,6 +903,7 @@
|
|||
(declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp) (%ac0) (%xp))
|
||||
(declare-intrinsic get-room get-room () (%xp) (%xp))
|
||||
(declare-intrinsic scan-remembered-set scan-remembered-set () () ())
|
||||
(declare-intrinsic reify-cc reify-cc (%xp %ac0 %ts) () ())
|
||||
(declare-intrinsic dooverflow dooverflow () () ())
|
||||
(declare-intrinsic dooverflood dooverflood () (%xp) ())
|
||||
; a dorest routine takes all of the register and frame arguments from the rest
|
||||
|
|
@ -1549,7 +1550,112 @@
|
|||
[,pr pr]
|
||||
[else ($oops who "unexpected Expr ~s" ir)]))
|
||||
|
||||
(define-pass np-name-anonymous-lambda : L4.875 (ir) -> L5 ()
|
||||
(define-pass np-recognize-attachment : L4.875 (ir) -> L4.9375 ()
|
||||
(definitions
|
||||
(define return
|
||||
(lambda (mode x)
|
||||
(case mode
|
||||
[(pop) (with-output-language (L4.9375 Expr)
|
||||
`(seq
|
||||
(attachment-set pop)
|
||||
,x))]
|
||||
[else x])))
|
||||
(define ->in-wca
|
||||
(lambda (mode)
|
||||
(case mode
|
||||
[(non-tail pop) 'pop]
|
||||
[(tail tail/reified) 'tail/reified]))))
|
||||
(CaseLambdaClause : CaseLambdaClause (cl) -> CaseLambdaClause ()
|
||||
[(clause (,x* ...) ,interface ,[Expr : body 'tail '() -> body])
|
||||
`(clause (,x* ...) ,interface ,body)])
|
||||
(Expr : Expr (ir [mode 'non-tail] [loop-x* '()]) -> Expr ()
|
||||
[,x (return mode x)]
|
||||
[(letrec ([,x* ,[le* 'non-tail '() -> le*]] ...) ,[body])
|
||||
`(letrec ([,x* ,le*] ...) ,body)]
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non-tail '() -> e1]
|
||||
(case-lambda ,info2 (clause () ,interface ,[body (->in-wca mode) '() -> body])))
|
||||
(guard (and (eq? (primref-name pr) 'call-setting-continuation-attachment)
|
||||
(= interface 0)))
|
||||
(case mode
|
||||
[(pop tail/reified)
|
||||
;; Definitely an attachment in place
|
||||
`(seq (attachment-set set ,e1) ,body)]
|
||||
[(tail)
|
||||
;; Check dynamically for reified continuation and attachment
|
||||
`(seq (attachment-set reify-and-set ,e1) ,body)]
|
||||
[(non-tail)
|
||||
;; Push attachment; `body` has been adjusted to pop
|
||||
`(seq (attachment-set push ,e1) ,body)])]
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non-tail '() -> e1]
|
||||
(case-lambda ,info2 (clause (,x) ,interface ,[body])))
|
||||
(guard (and (eq? (primref-name pr) 'call-with-current-continuation-attachment)
|
||||
(= interface 1)))
|
||||
(case mode
|
||||
[(non-tail)
|
||||
;; No surrounding `with-continuation-attachment`
|
||||
`(let ([,x ,e1]) ,body)]
|
||||
[(pop tail/reified)
|
||||
;; Defintely an attachment in place
|
||||
`(seq ,e1 (let ([,x (attachment-get)]) ,body))]
|
||||
[else
|
||||
;; Check dynamically for attachment
|
||||
`(let ([,x (attachment-get ,e1)]) ,body)])]
|
||||
[(call ,info ,mdcl ,x ,[e* 'non-tail '() -> e*] ...)
|
||||
(guard (memq x loop-x*))
|
||||
;; No convert for a loop call, even if mode is 'pop
|
||||
`(call ,info ,mdcl ,x ,e* ...)]
|
||||
[(call ,info ,mdcl ,[e 'non-tail '() -> e] ,[e* 'non-tail '() -> e*] ...)
|
||||
(let ([new-e (case mode
|
||||
[(pop)
|
||||
(let ([level (if (info-call-check? info) 2 3)]
|
||||
[p-info (make-info-call #f #f #f #f #f)])
|
||||
`(call ,p-info #f ,(lookup-primref level '$make-shift-attachment) ,e))]
|
||||
[else e])])
|
||||
`(call ,info ,(and (eq? new-e e) mdcl) ,new-e ,e* ...))]
|
||||
[(foreign-call ,info ,[e 'non-tail '() -> e] ,[e* 'non-tail '() -> e*] ...)
|
||||
(return mode `(foreign-call ,info ,e ,e* ...))]
|
||||
[(fcallable ,info) (return mode `(fcallable ,info))]
|
||||
[(label ,l ,[body]) `(label ,l ,body)]
|
||||
[(mvlet ,[e 'non-tail '() -> e] ((,x** ...) ,interface* ,body*) ...)
|
||||
(let ([body* (map (lambda (body interface)
|
||||
(case (and (fx< interface 0)
|
||||
mode)
|
||||
[(pop)
|
||||
;; If `body` is a direct call, then we need to change
|
||||
;; to an `apply`, since the last argument is turned
|
||||
;; into a list already. It would have been better to
|
||||
;; avoid the direct-call setup in the first place.
|
||||
(nanopass-case (L4.875 Expr) body
|
||||
[(call ,info ,mdcl ,e ,e* ...)
|
||||
(guard mdcl)
|
||||
(%primcall info #f apply
|
||||
,(%primcall #f #f $make-shift-attachment ,e)
|
||||
,e* ...)]
|
||||
[else
|
||||
(Expr body 'pop loop-x*)])]
|
||||
[else
|
||||
(Expr body mode loop-x*)]))
|
||||
body* interface*)])
|
||||
`(mvlet ,e ((,x** ...) ,interface* ,body*) ...))]
|
||||
[(mvcall ,info ,[e1 'non-tail '() -> e1] ,[e2 'non-tail '() -> e2])
|
||||
(let ([e2 (case mode
|
||||
[(pop) (%primcall #f #f $make-shift-attachment ,e2)]
|
||||
[else e2])])
|
||||
`(mvcall ,info ,e1 ,e2))]
|
||||
[(let ([,x* ,[e* 'non-tail '() -> e*]] ...) ,[body])
|
||||
`(let ([,x* ,e*] ...) ,body)]
|
||||
[(case-lambda ,info ,[cl] ...) (return mode `(case-lambda ,info ,cl ...))]
|
||||
[(quote ,d) (return mode `(quote ,d))]
|
||||
[(if ,[e0 'non-tail '() -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
|
||||
[(seq ,[e0 'non-tail '() -> e0] ,[e1]) `(seq ,e0 ,e1)]
|
||||
[(profile ,src) `(profile ,src)]
|
||||
[(pariah) `(pariah)]
|
||||
[,pr (return mode pr)]
|
||||
[(loop ,x (,x* ...) ,[body mode (cons x loop-x*) -> body])
|
||||
`(loop ,x (,x* ...) ,body)]
|
||||
[else ($oops who "unexpected Expr ~s" ir)]))
|
||||
|
||||
(define-pass np-name-anonymous-lambda : L4.9375 (ir) -> L5 ()
|
||||
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ())
|
||||
(Expr : Expr (ir) -> Expr ()
|
||||
[(case-lambda ,info ,[cl] ...)
|
||||
|
|
@ -1559,7 +1665,7 @@
|
|||
(uvar-info-lambda-set! anon info)
|
||||
`(letrec ([,anon (case-lambda ,info ,cl ...)])
|
||||
,anon))])
|
||||
(nanopass-case (L4.875 CaseLambdaExpr) ir
|
||||
(nanopass-case (L4.9375 CaseLambdaExpr) ir
|
||||
[(case-lambda ,info ,[CaseLambdaClause : cl] ...) `(case-lambda ,info ,cl ...)]))
|
||||
|
||||
(define-pass np-convert-closures : L5 (x) -> L6 ()
|
||||
|
|
@ -2692,6 +2798,32 @@
|
|||
,[e*] ...)
|
||||
(guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d)))
|
||||
`(call ,info0 ,mdcl0 ,(Symref d) ,e* ...)]
|
||||
[(call ,info0 ,mdcl0
|
||||
(call ,info1 ,mdcl1 ,pr
|
||||
(call ,info2 ,mdcl2 ,pr2 (quote ,d)))
|
||||
,[e*] ...)
|
||||
(guard (and (eq? (primref-name pr) '$make-shift-attachment)
|
||||
(eq? (primref-name pr2) '$top-level-value) (symbol? d)))
|
||||
`(call ,info0 ,mdcl0 (call ,info1 ,mdcl1 ,(Symref (primref-name pr)) ,(Symref d)) ,e* ...)]
|
||||
[(call ,info ,mdcl (call ,info2 ,mdcl2 ,pr0 ,pr) ,e* ...)
|
||||
(guard (eq? (primref-name pr0) '$make-shift-attachment)
|
||||
;; FIXME: need a less fragile way to avoid multiple results
|
||||
;; Exclude inlined primitives that return more than one value:
|
||||
(not (memq (primref-name pr) '(values call/cc call-with-current-continuation call/1cc))))
|
||||
(cond
|
||||
[(handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)
|
||||
=> (lambda (e)
|
||||
(let ([t (make-tmp 't)])
|
||||
`(let ([,t ,(Expr e)])
|
||||
(seq
|
||||
(attachment-set pop)
|
||||
,t))))]
|
||||
[else
|
||||
(let ([e* (map Expr e*)])
|
||||
(let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr))
|
||||
(make-info-call (info-call-src info) (info-call-sexpr info) (info-call-check? info) #t #t)
|
||||
info)])
|
||||
`(call ,info ,mdcl (call ,info2 ,mdcl2 ,(Symref (primref-name pr0)) ,(Symref (primref-name pr))) ,e* ...)))])]
|
||||
[(call ,info ,mdcl ,pr ,e* ...)
|
||||
(cond
|
||||
[(handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*) => Expr]
|
||||
|
|
@ -5011,6 +5143,7 @@
|
|||
(inline-accessor $code-pinfo* code-pinfo*-disp)
|
||||
(inline-accessor $continuation-link continuation-link-disp)
|
||||
(inline-accessor $continuation-winders continuation-winders-disp)
|
||||
(inline-accessor $continuation-attachments continuation-attachments-disp)
|
||||
(inline-accessor csv7:record-type-descriptor record-type-disp)
|
||||
(inline-accessor $record-type-descriptor record-type-disp)
|
||||
(inline-accessor record-rtd record-type-disp)
|
||||
|
|
@ -5281,7 +5414,8 @@
|
|||
(let ()
|
||||
(define hand-coded-closure?
|
||||
(lambda (name)
|
||||
(not (memq name '(nuate nonprocedure-code error-invoke invoke)))))
|
||||
(not (memq name '(nuate nonprocedure-code error-invoke invoke
|
||||
$shift-attachment)))))
|
||||
(define-inline 2 $hand-coded
|
||||
[(name)
|
||||
(nanopass-case (L7 Expr) name
|
||||
|
|
@ -5370,10 +5504,23 @@
|
|||
(define-tc-parameter $target-machine target-machine)
|
||||
(define-tc-parameter $current-stack-link stack-link)
|
||||
(define-tc-parameter $current-winders winders)
|
||||
(define-tc-parameter $current-attachments attachments)
|
||||
(define-tc-parameter default-record-equal-procedure default-record-equal-procedure)
|
||||
(define-tc-parameter default-record-hash-procedure default-record-hash-procedure)
|
||||
)
|
||||
|
||||
(define-inline 3 $make-shift-attachment
|
||||
[(e-proc)
|
||||
(bind #f (e-proc)
|
||||
(bind #t ([c (%constant-alloc type-closure (fx* 3 (constant ptr-bytes)))])
|
||||
(%seq
|
||||
(set! ,(%mref ,c ,(constant closure-code-disp))
|
||||
(literal ,(make-info-literal #f 'library
|
||||
(lookup-libspec $shift-attachment)
|
||||
(constant code-data-disp))))
|
||||
(set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc)
|
||||
,c)))])
|
||||
|
||||
(define-inline 3 $install-guardian
|
||||
[(e-obj e-rep e-tconc)
|
||||
(bind #f (e-obj e-rep e-tconc)
|
||||
|
|
@ -9555,6 +9702,14 @@
|
|||
(if e0?
|
||||
(Triv* (cons e0? e1*) (lambda (t*) (k `(call ,info ,mdcl ,(car t*) ,(cdr t*) ...))))
|
||||
(Triv* e1* (lambda (t*) (k `(call ,info ,mdcl #f ,t* ...)))))]
|
||||
[(attachment-get ,e* ...)
|
||||
(Triv* e*
|
||||
(lambda (t*)
|
||||
(k `(attachment-get ,t* ...))))]
|
||||
[(attachment-set ,aop ,e* ...)
|
||||
(Triv* e*
|
||||
(lambda (t*)
|
||||
(k `(attachment-set ,aop ,t* ...))))]
|
||||
[(foreign-call ,info ,e0 ,e1* ...)
|
||||
(Triv* (cons e0 e1*)
|
||||
(lambda (t*)
|
||||
|
|
@ -9898,6 +10053,8 @@
|
|||
[(set! ,[lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
|
||||
(guard (info-call-error? info) (fx< (debug-level) 2))
|
||||
`(tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...)))]
|
||||
[(set! ,[lvalue] (attachment-get ,[t*] ...))
|
||||
`(set! ,lvalue (attachment-get ,t* ...))]
|
||||
[(label ,l ,[ebody]) `(seq (label ,l) ,ebody)]
|
||||
[(trap-check ,ioc ,[ebody]) `(seq (trap-check ,ioc) ,ebody)]
|
||||
[(overflow-check ,[ebody]) `(seq (overflow-check) ,ebody)]
|
||||
|
|
@ -9915,7 +10072,8 @@
|
|||
(%seq ,e (goto ,join)
|
||||
,(f `(seq (label ,(car l*)) ,(car e*)) (cdr l*) (cdr e*)))))
|
||||
(label ,join)))]
|
||||
[(values ,info ,t* ...) `(nop)])
|
||||
[(values ,info ,t* ...) `(nop)]
|
||||
[(attachment-get ,t* ...) `(nop)])
|
||||
(Tail : Expr (ir) -> Tail ()
|
||||
[(inline ,info ,prim ,[t*] ...)
|
||||
(guard (pred-primitive? prim))
|
||||
|
|
@ -10941,6 +11099,11 @@
|
|||
; (new) stack base in sfp, clength in ac1, old frame base in yp
|
||||
; set up return address and stack link
|
||||
(set! ,(%tc-ref stack-link) ,(%mref ,xp/cp ,(constant continuation-link-disp)))
|
||||
; potentially pop an attachment
|
||||
(set! ,%ts ,(%mref ,xp/cp ,(constant continuation-attachments-disp)))
|
||||
(if ,(%inline eq? ,(%constant sfalse) ,%ts)
|
||||
(nop)
|
||||
(set! ,(%tc-ref attachments) ,%ts))
|
||||
; set %td to end of the destination area / base of stack values dest
|
||||
(set! ,%td ,(%inline + ,%td ,%sfp))
|
||||
; don't shift if no stack values
|
||||
|
|
@ -11058,7 +11221,52 @@
|
|||
(set! ,%xp ,(%mref ,xp/cp ,(constant continuation-return-address-disp)))
|
||||
(set! ,fv0 ,%xp)
|
||||
(jump ,(%mref ,%xp ,(constant return-address-mv-return-address-disp))
|
||||
(,%ac0 ,arg-registers ... ,fv0))))]))))))))))))
|
||||
(,%ac0 ,arg-registers ... ,fv0))))])))))))))))
|
||||
(define reify-cc-help
|
||||
(lambda (finish)
|
||||
(with-output-language (L13 Tail)
|
||||
(let ([Ltop (make-local-label 'Ltop)])
|
||||
(%seq
|
||||
(set! ,%td ,(%tc-ref stack-link))
|
||||
(set! ,%xp ,%td)
|
||||
(label ,Ltop)
|
||||
(set! ,%ac0 ,(%mref ,%xp ,(constant continuation-stack-clength-disp)))
|
||||
(if ,(%inline eq?
|
||||
,(%mref ,%xp ,(constant continuation-stack-length-disp))
|
||||
,%ac0)
|
||||
,(%seq
|
||||
(set! ,%ac0
|
||||
(literal ,(make-info-literal #f 'library-code
|
||||
(lookup-libspec dounderflow)
|
||||
(fx+ (constant code-data-disp) (constant size-rp-header)))))
|
||||
(if (if ,(%inline eq?
|
||||
,(%mref ,%td ,(constant continuation-attachments-disp))
|
||||
,(%constant sfalse))
|
||||
(false)
|
||||
,(%inline eq? ,%ref-ret ,%ac0))
|
||||
,(finish %td)
|
||||
,(%seq
|
||||
(set! ,%xp ,(%constant-alloc type-closure (constant size-continuation)))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-code-disp))
|
||||
(literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-attachments-disp)) ,(%tc-ref attachments))
|
||||
(set! ,%ref-ret ,%ac0)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-link-disp)) ,%td)
|
||||
(set! ,(%tc-ref stack-link) ,%xp)
|
||||
(set! ,%ac0 ,(%tc-ref scheme-stack))
|
||||
(set! ,(%tc-ref scheme-stack) ,%sfp)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-disp)) ,%ac0)
|
||||
(set! ,%ac0 ,(%inline - ,%sfp ,%ac0))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-clength-disp)) ,%ac0)
|
||||
(set! ,(%tc-ref scheme-stack-size) ,(%inline - ,(%tc-ref scheme-stack-size) ,%ac0))
|
||||
,(finish %xp))))
|
||||
,(%seq
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
|
||||
(set! ,%xp ,(%mref ,%xp ,(constant continuation-link-disp)))
|
||||
(goto ,Ltop)))))))))
|
||||
(Program : Program (ir) -> Program ()
|
||||
[(labels ([,l* ,le*] ...) ,l)
|
||||
`(labels ([,l* ,(map CaseLambdaExpr le* l*)] ...) ,l)])
|
||||
|
|
@ -11084,28 +11292,55 @@
|
|||
[(dorest3) (make-do-rest 3 frame-args-offset)]
|
||||
[(dorest4) (make-do-rest 4 frame-args-offset)]
|
||||
[(dorest5) (make-do-rest 5 frame-args-offset)]
|
||||
[(reify-cc)
|
||||
(let ([other-reg* (fold-left (lambda (live* kill) (remq kill live*))
|
||||
(vector->list regvec)
|
||||
;; Registers used by `reify-cc-help` output,
|
||||
;; plus `%ts` so that we have one to allocate
|
||||
(reg-list %xp %td %ac0 %ts))])
|
||||
`(lambda ,(make-named-info-lambda "reify-cc" '(0)) 0 ()
|
||||
,(asm-enter
|
||||
(%seq
|
||||
(check-live ,other-reg* ...)
|
||||
,(reify-cc-help
|
||||
(lambda (reg)
|
||||
(if (eq? reg %td)
|
||||
`(asm-return ,%td ,other-reg* ...)
|
||||
`(seq
|
||||
(set! ,%td ,reg)
|
||||
(asm-return ,%td ,other-reg* ...)))))))))]
|
||||
[(callcc)
|
||||
(let ([Ltop (make-local-label 'Ltop)])
|
||||
;; Could be implemented using the `reify-cc` intrinsic, as follows,
|
||||
;; but, we inline `reify-cc` to save a few instructions
|
||||
#;
|
||||
`(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
|
||||
,(%seq
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
|
||||
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
|
||||
(set! ,(make-arg-opnd 1) ,%td)
|
||||
,(do-call 1)))
|
||||
`(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
|
||||
,(%seq
|
||||
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
|
||||
(set! ,%td ,(%tc-ref stack-link))
|
||||
(set! ,%xp ,%td)
|
||||
(label ,Ltop)
|
||||
(set! ,%ac0 ,(%mref ,%xp ,(constant continuation-stack-clength-disp)))
|
||||
(if ,(%inline eq?
|
||||
,(%mref ,%xp ,(constant continuation-stack-length-disp))
|
||||
,%ac0)
|
||||
,(reify-cc-help
|
||||
(lambda (reg)
|
||||
(%seq
|
||||
(set! ,(make-arg-opnd 1) ,reg)
|
||||
,(do-call 1))))))]
|
||||
[(call1cc)
|
||||
`(lambda ,(make-named-info-lambda 'call1cc '(1)) 0 ()
|
||||
,(%seq
|
||||
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
|
||||
(set! ,%td ,(%tc-ref stack-link))
|
||||
(set! ,%ac0
|
||||
(literal ,(make-info-literal #f 'library-code
|
||||
(lookup-libspec dounderflow)
|
||||
(fx+ (constant code-data-disp) (constant size-rp-header)))))
|
||||
(if (if ,(%inline eq? ,%ref-ret ,%ac0)
|
||||
,(%inline eq?
|
||||
,(%mref ,%td ,(constant continuation-winders-disp))
|
||||
,(%tc-ref winders))
|
||||
(false))
|
||||
(if (if ,(%inline eq?
|
||||
,(%mref ,%td ,(constant continuation-attachments-disp))
|
||||
,(%constant sfalse))
|
||||
(false)
|
||||
,(%inline eq? ,%ref-ret ,%ac0))
|
||||
,(%seq
|
||||
(set! ,(make-arg-opnd 1) ,%td)
|
||||
,(do-call 1))
|
||||
|
|
@ -11117,48 +11352,7 @@
|
|||
(literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
|
||||
(set! ,%ref-ret ,%ac0)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-link-disp)) ,%td)
|
||||
(set! ,(%tc-ref stack-link) ,%xp)
|
||||
(set! ,%ac0 ,(%tc-ref scheme-stack))
|
||||
(set! ,(%tc-ref scheme-stack) ,%sfp)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-disp)) ,%ac0)
|
||||
(set! ,%ac0 ,(%inline - ,%sfp ,%ac0))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-clength-disp)) ,%ac0)
|
||||
(set! ,(%tc-ref scheme-stack-size) ,(%inline - ,(%tc-ref scheme-stack-size) ,%ac0))
|
||||
(set! ,(make-arg-opnd 1) ,%xp)
|
||||
,(do-call 1))))
|
||||
,(%seq
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
|
||||
(set! ,%xp ,(%mref ,%xp ,(constant continuation-link-disp)))
|
||||
(goto ,Ltop))))))]
|
||||
[(call1cc)
|
||||
`(lambda ,(make-named-info-lambda 'call1cc '(1)) 0 ()
|
||||
,(%seq
|
||||
(set! ,(ref-reg %cp) ,(make-arg-opnd 1))
|
||||
(set! ,%td ,(%tc-ref stack-link))
|
||||
(set! ,%ac0
|
||||
(literal ,(make-info-literal #f 'library-code
|
||||
(lookup-libspec dounderflow)
|
||||
(fx+ (constant code-data-disp) (constant size-rp-header)))))
|
||||
(if (if ,(%inline eq? ,%ref-ret ,%ac0)
|
||||
,(%inline eq?
|
||||
,(%mref ,%td ,(constant continuation-winders-disp))
|
||||
,(%tc-ref winders))
|
||||
(false))
|
||||
,(%seq
|
||||
(set! ,(make-arg-opnd 1) ,%td)
|
||||
,(do-call 1))
|
||||
,(%seq
|
||||
(set! ,%xp ,(%constant-alloc type-closure (constant size-continuation)))
|
||||
; TODO: remove next line once get-room preserves %td
|
||||
(set! ,%td ,(%tc-ref stack-link))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-code-disp))
|
||||
(literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp))))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
|
||||
(set! ,(%mref ,%xp ,(constant continuation-winders-disp))
|
||||
,(%tc-ref winders))
|
||||
(set! ,(%mref ,%xp ,(constant continuation-attachments-disp)) ,(%tc-ref attachments))
|
||||
,(meta-cond
|
||||
[(real-register? '%ret) `(set! ,%ret ,%ac0)]
|
||||
[else `(nop)])
|
||||
|
|
@ -11273,7 +11467,9 @@
|
|||
[(mref ,x1 ,x2 ,imm) (%mref ,(Ref x1) ,(Ref x2) ,imm)])
|
||||
(Rhs : Rhs (ir) -> Rhs ()
|
||||
[(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))
|
||||
($oops who "Effect is responsible for handling mvcalls")])
|
||||
($oops who "Effect is responsible for handling mvcalls")]
|
||||
[(attachment-get ,t* ...)
|
||||
($oops who "Effect is responsible for handling attachment-gets")])
|
||||
(Effect : Effect (ir) -> Effect ()
|
||||
[(do-rest ,fixed-args)
|
||||
(if (fx<= fixed-args dorest-intrinsic-max)
|
||||
|
|
@ -11317,7 +11513,64 @@
|
|||
[(foreign-call ,info ,[t0] ,[t1*] ...)
|
||||
(build-foreign-call info t0 t1* #f #t)]
|
||||
[(set! ,[lvalue] (foreign-call ,info ,[t0] ,[t1*] ...))
|
||||
(build-foreign-call info t0 t1* lvalue #t)])
|
||||
(build-foreign-call info t0 t1* lvalue #t)]
|
||||
[(set! ,[lvalue] (attachment-get))
|
||||
;; No default expression => an attachment is certainly available
|
||||
(let ([ats (make-tmp 'ats)])
|
||||
(%seq
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))))]
|
||||
[(set! ,[lvalue] (attachment-get ,[t]))
|
||||
;; Default expression => need to check for reified continuation
|
||||
;; and attachment beyond it. For now, we always reify the continuation
|
||||
;; to simplify the check
|
||||
(let ([ats (make-tmp 'ats)])
|
||||
(%seq
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats)
|
||||
(set! ,lvalue ,t)
|
||||
(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp))))))]
|
||||
[(attachment-set ,aop)
|
||||
(case aop
|
||||
[(pop)
|
||||
(let ([ats (make-tmp 'ats)])
|
||||
(%seq
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(set! ,(%tc-ref attachments) ,(%mref ,ats ,(constant pair-cdr-disp)))))]
|
||||
[else
|
||||
($oops who "unexpected attachment-set mode ~s" aop)])]
|
||||
[(attachment-set ,aop ,[t])
|
||||
(let ([ats (make-tmp 'ats)])
|
||||
(define (make-push)
|
||||
(let ([p (make-tmp 'pr)])
|
||||
;; Generate
|
||||
;; ($current-attachments (cons t ($current-attachments)))
|
||||
(%seq
|
||||
(set! ,p ,(%constant-alloc type-pair (constant size-pair)))
|
||||
(set! ,(%mref ,p ,(constant pair-car-disp)) ,t)
|
||||
(set! ,(%mref ,p ,(constant pair-cdr-disp)) ,ats)
|
||||
(set! ,(%tc-ref attachments) ,p))))
|
||||
(case aop
|
||||
[(push)
|
||||
(%seq
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
,(make-push))]
|
||||
[(set)
|
||||
(%seq
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp)))
|
||||
,(make-push))]
|
||||
[(reify-and-set)
|
||||
(%seq
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats)
|
||||
(nop)
|
||||
(set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp))))
|
||||
,(make-push))]
|
||||
[else
|
||||
($oops who "unexpected attachment-set mode ~s" aop)]))])
|
||||
(Tail : Tail (ir) -> Tail ()
|
||||
[(entry-point (,x* ...) ,dcl ,mcp ,tlbody)
|
||||
(unless (andmap (lambda (x) (eq? (uvar-type x) 'ptr)) x*)
|
||||
|
|
@ -12171,6 +12424,32 @@
|
|||
(out %ac0 %ac1 %cp %xp %yp %ts %td scheme-args extra-regs))))
|
||||
(set! ,%ac0 ,(%constant svoid))
|
||||
(jump ,%ref-ret (,%ac0))))]
|
||||
[($shift-attachment)
|
||||
;; Reify the continuation, but dropping the first `attachments` element,
|
||||
;; which must be present, so that the attachment will be popped
|
||||
;; on return from the continuation
|
||||
(let ([info (make-info "$shift-attachment" '())])
|
||||
(info-lambda-fv*-set! info '(proc))
|
||||
`(lambda ,info 0 ()
|
||||
,(%seq
|
||||
(set! ,(ref-reg %ac1) ,%ac0) ; save argument count
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))
|
||||
(set! ,%ts ,(%mref ,%td ,(constant continuation-attachments-disp)))
|
||||
(set! ,(%mref ,%td ,(constant continuation-attachments-disp)) ,(%mref ,%ts ,(constant pair-cdr-disp)))
|
||||
(set! ,%ac0 ,(ref-reg %ac1)) ; restore argument count
|
||||
,(meta-cond
|
||||
[(real-register? '%cp)
|
||||
(%seq
|
||||
(set! ,%cp ,(%mref ,%cp ,(constant closure-data-disp)))
|
||||
(jump ,(%mref ,%cp ,(constant closure-code-disp))
|
||||
(,%ac0 ,%cp ,(reg-cons* %ret arg-registers) ...)))]
|
||||
[else
|
||||
(%seq
|
||||
(set! ,%td ,(ref-reg %cp))
|
||||
(set! ,%td ,(%mref ,%td ,(constant closure-data-disp)))
|
||||
(set! ,(ref-reg %cp) ,%td)
|
||||
(jump ,(%mref ,%td ,(constant closure-code-disp))
|
||||
(,%ac0 ,(reg-cons* %ret arg-registers) ...)))]))))]
|
||||
[(bytevector=?)
|
||||
(let ([bv1 (make-tmp 'bv1)] [bv2 (make-tmp 'bv2)] [idx (make-tmp 'idx)] [len2 (make-tmp 'len2)])
|
||||
(define (argcnt->max-fv n) (max (- n (length arg-registers)) 0))
|
||||
|
|
@ -15951,6 +16230,7 @@
|
|||
(pass np-recognize-mrvs unparse-L4.5)
|
||||
(pass np-expand-foreign unparse-L4.75)
|
||||
(pass np-recognize-loops unparse-L4.875)
|
||||
(pass np-recognize-attachment unparse-L4.9375)
|
||||
(pass np-name-anonymous-lambda unparse-L5)
|
||||
(pass np-convert-closures unparse-L6)
|
||||
(pass np-optimize-direct-call unparse-L6)
|
||||
|
|
|
|||
|
|
@ -2510,7 +2510,8 @@
|
|||
(compute-size ($continuation-return-code x))
|
||||
(compute-size ($closure-code x))
|
||||
(compute-size ($continuation-link x))
|
||||
(compute-size ($continuation-winders x)))])
|
||||
(compute-size ($continuation-winders x))
|
||||
(compute-size ($continuation-attachments x)))])
|
||||
(if (fx>= i len)
|
||||
size
|
||||
(loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size)))))))
|
||||
|
|
@ -2665,6 +2666,7 @@
|
|||
(compute-composition! ($closure-code x))
|
||||
(compute-composition! ($continuation-link x))
|
||||
(compute-composition! ($continuation-winders x))
|
||||
(compute-composition! ($continuation-attachments x))
|
||||
(let ([len ($continuation-stack-length x)])
|
||||
(incr! stack (align (fx* len (constant ptr-bytes))))
|
||||
(let loop ([i 1] [lpm ($continuation-return-livemask x)])
|
||||
|
|
@ -2803,7 +2805,8 @@
|
|||
(let ([len ($continuation-stack-length x)])
|
||||
(let loop ([i 1] [lpm ($continuation-return-livemask x)])
|
||||
(if (fx>= i len)
|
||||
(construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) ($continuation-winders x) next-proc)
|
||||
(construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x)
|
||||
($continuation-winders x) ($continuation-attachments x) next-proc)
|
||||
(if (odd? lpm)
|
||||
(construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1)))
|
||||
(loop (fx+ i 1) (ash lpm -1))))))))
|
||||
|
|
|
|||
|
|
@ -111,6 +111,7 @@
|
|||
;;; dounderflow & nuate must come before callcc
|
||||
(define-hand-coded-library-entry dounderflow)
|
||||
(define-hand-coded-library-entry nuate)
|
||||
(define-hand-coded-library-entry reify-cc)
|
||||
(define-hand-coded-library-entry callcc)
|
||||
(define-hand-coded-library-entry call1cc)
|
||||
(define-hand-coded-library-entry dofargint32)
|
||||
|
|
@ -124,6 +125,7 @@
|
|||
(define-hand-coded-library-entry dofretu32*)
|
||||
(define-hand-coded-library-entry domvleterr)
|
||||
(define-hand-coded-library-entry values-error)
|
||||
(define-hand-coded-library-entry $shift-attachment)
|
||||
(define-hand-coded-library-entry bytevector=?)
|
||||
|
||||
(define $instantiate-code-object ($hand-coded '$instantiate-code-object))
|
||||
|
|
|
|||
|
|
@ -885,12 +885,14 @@
|
|||
(defref RELOCCODE reloc-table code)
|
||||
(defref RELOCIT reloc-table data)
|
||||
|
||||
(defref CONTCODE continuation code)
|
||||
(defref CONTSTACK continuation stack)
|
||||
(defref CONTLENGTH continuation stack-length)
|
||||
(defref CONTCLENGTH continuation stack-clength)
|
||||
(defref CONTLINK continuation link)
|
||||
(defref CONTRET continuation return-address)
|
||||
(defref CONTWINDERS continuation winders)
|
||||
(defref CONTATTACHMENTS continuation attachments)
|
||||
|
||||
(defref RTDCOUNTSTYPE rtd-counts type)
|
||||
(defref RTDCOUNTSTIMESTAMP rtd-counts timestamp)
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@
|
|||
block-pariah! block-seen! block-finished! block-return-point! block-repeater! block-loop-header!
|
||||
block-pariah? block-seen? block-finished? block-return-point? block-repeater? block-loop-header?
|
||||
L1 unparse-L1 L2 unparse-L2 L3 unparse-L3 L4 unparse-L4
|
||||
L4.5 unparse-L4.5 L4.75 unparse-L4.75 L4.875 unparse-L4.875
|
||||
L4.5 unparse-L4.5 L4.75 unparse-L4.75 L4.875 unparse-L4.875 L4.9375 unparse-L4.9375
|
||||
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
|
||||
|
|
@ -382,8 +382,21 @@
|
|||
(Expr (e body)
|
||||
(+ (loop x (x* ...) body) => (loop x body))))
|
||||
|
||||
(define attachment-op?
|
||||
(lambda (x)
|
||||
(memq x '(push pop set reify-and-set))))
|
||||
|
||||
; exposes continuation-attachment operations
|
||||
(define-language L4.9375 (extends L4.875)
|
||||
(terminals
|
||||
(+ (attachment-op (aop))))
|
||||
(entry CaseLambdaExpr)
|
||||
(Expr (e body)
|
||||
(+ (attachment-set aop e* ...)
|
||||
(attachment-get e* ...))))
|
||||
|
||||
; moves all case lambda expressions into rhs of letrec
|
||||
(define-language L5 (extends L4.875)
|
||||
(define-language L5 (extends L4.9375)
|
||||
(entry CaseLambdaExpr)
|
||||
(Expr (e body)
|
||||
(- le)))
|
||||
|
|
@ -655,7 +668,8 @@
|
|||
(alloc info t) => (alloc info t)
|
||||
(inline info prim t* ...) => (inline info prim t* ...)
|
||||
(mvcall info e t) => (mvcall e t)
|
||||
(foreign-call info t t* ...)))
|
||||
(foreign-call info t t* ...)
|
||||
(attachment-get t* ...)))
|
||||
(Expr (e body)
|
||||
(- lvalue
|
||||
(values info e* ...)
|
||||
|
|
@ -668,7 +682,8 @@
|
|||
(let ([x e] ...) body)
|
||||
(set! lvalue e)
|
||||
(mvcall info e1 e2)
|
||||
(foreign-call info e e* ...))
|
||||
(foreign-call info e e* ...)
|
||||
(attachment-get e* ...))
|
||||
(+ rhs
|
||||
(values info t* ...)
|
||||
(set! lvalue rhs))))
|
||||
|
|
@ -716,7 +731,8 @@
|
|||
(pariah)
|
||||
(trap-check ioc e)
|
||||
(overflow-check e)
|
||||
(profile src)))
|
||||
(profile src)
|
||||
(attachment-set aop e* ...)))
|
||||
(Tail (tl tlbody)
|
||||
(+ rhs
|
||||
(if p0 tl1 tl2)
|
||||
|
|
@ -747,6 +763,7 @@
|
|||
(mvset (mdcl t0 t1 ...) (t* ...) ((x** ...) interface* l*) ...)
|
||||
(mvcall info mdcl (maybe t0) t1 ... (t* ...)) => (mvcall mdcl t0 t1 ... (t* ...))
|
||||
(foreign-call info t t* ...)
|
||||
(attachment-set aop t* ...)
|
||||
(tail tl))))
|
||||
|
||||
(define-language L11.5 (extends L11)
|
||||
|
|
|
|||
|
|
@ -1170,8 +1170,10 @@
|
|||
(bytevector-compress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(bytevector-uncompress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(call/1cc [sig [(procedure) -> (ptr ...)]] [flags])
|
||||
(call-with-current-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
|
||||
(cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
|
||||
(cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder])
|
||||
|
|
@ -1219,6 +1221,7 @@
|
|||
(condition-wait [feature pthreads] [sig [(condition-object mutex) (condition-object mutex timeout) -> (boolean)]] [flags])
|
||||
(conjugate [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
(continuation-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
|
||||
(continuation-next-attachments [sig [(ptr) -> (list)]] [flags])
|
||||
(copy-environment [sig [(environment) (environment ptr) (environment ptr sub-list) -> (environment)]] [flags alloc])
|
||||
(copy-time [sig [(time) -> (time)]] [flags alloc])
|
||||
(cosh [sig [(number) -> (number)]] [flags arith-op mifoldable discard])
|
||||
|
|
@ -1228,6 +1231,7 @@
|
|||
(cost-center-time [sig [(cost-center) -> (time)]] [flags mifoldable discard true])
|
||||
(cpu-time [sig [() -> (uint)]] [flags unrestricted alloc])
|
||||
(create-exception-state [sig [() (procedure) -> (void)]] [flags alloc])
|
||||
(current-continuation-attachments [sig [() -> (list)]] [flags alloc])
|
||||
(current-memory-bytes [sig [() -> (uint)]] [flags alloc])
|
||||
(date-and-time [sig [() (date) -> (string)]] [flags unrestricted alloc])
|
||||
(datum->syntax-object [sig [(identifier ptr) -> (ptr)]] [flags pure mifoldable discard true])
|
||||
|
|
@ -1767,6 +1771,7 @@
|
|||
($continuation-stack-length [flags])
|
||||
($continuation-stack-ref [flags])
|
||||
($continuation-winders [flags])
|
||||
($continuation-attachments [flags])
|
||||
($cp0 [flags])
|
||||
($cpcheck [flags])
|
||||
($cpcheck-prelex-flags [flags])
|
||||
|
|
@ -1776,6 +1781,7 @@
|
|||
($c-stlv! [flags])
|
||||
($cte-optimization-info [flags])
|
||||
($c-tlv [flags])
|
||||
($current-attachments [flags])
|
||||
($current-stack-link [flags])
|
||||
($current-winders [flags])
|
||||
($distinct-bound-ids? [flags])
|
||||
|
|
@ -2086,6 +2092,7 @@
|
|||
($make-record-type #;[sig [(rtd maybe-rtd sub-ptr sub-list ptr ptr ptr ...) -> (rtd)]] [flags pure alloc cp02])
|
||||
($make-relocation-table! [flags])
|
||||
($make-rnrs-libraries [flags])
|
||||
($make-shift-attachment [flags])
|
||||
($make-source-oops [flags])
|
||||
($make-src-condition [flags])
|
||||
($make-textual-input/output-port #;[sig [(string port-handler string string) (string port-handler string string ptr) -> (textual-input/output-port)]] [flags alloc])
|
||||
|
|
|
|||
42
s/prims.ss
42
s/prims.ss
|
|
@ -366,6 +366,24 @@
|
|||
($oops who "~s is not a procedure" p))
|
||||
(#3%call/cc p)))
|
||||
|
||||
(define-who call-setting-continuation-attachment
|
||||
(lambda (v p)
|
||||
(unless (procedure? p)
|
||||
($oops who "~s is not a procedure" p))
|
||||
(#3%call-setting-continuation-attachment v (lambda () (p)))))
|
||||
|
||||
(define-who call-with-current-continuation-attachment
|
||||
(lambda (default-val p)
|
||||
(unless (procedure? p)
|
||||
($oops who "~s is not a procedure" p))
|
||||
(#3%call-with-current-continuation-attachment default-val (lambda (x) (p x)))))
|
||||
|
||||
(define $make-shift-attachment
|
||||
(lambda (proc)
|
||||
(if (procedure? proc)
|
||||
(#3%$make-shift-attachment proc)
|
||||
($oops #f "attempt to apply non-procedure ~s" proc))))
|
||||
|
||||
(define $code? (lambda (x) ($code? x)))
|
||||
|
||||
(define $system-code? (lambda (x) ($system-code? x)))
|
||||
|
|
@ -479,6 +497,12 @@
|
|||
($oops '$continuation-winders "~s is not a continuation" x))
|
||||
($continuation-winders x)))
|
||||
|
||||
(define $continuation-attachments
|
||||
(lambda (x)
|
||||
(unless ($continuation? x)
|
||||
($oops '$continuation-attachments "~s is not a continuation" x))
|
||||
($continuation-attachments x)))
|
||||
|
||||
(define $continuation-return-code
|
||||
(lambda (x)
|
||||
(unless ($continuation? x)
|
||||
|
|
@ -1392,13 +1416,23 @@
|
|||
($oops '$current-stack-link "invalid argument ~s" k))
|
||||
($current-stack-link k)]))
|
||||
|
||||
(define $current-winders
|
||||
(define-who $current-winders
|
||||
(let ()
|
||||
(include "types.ss")
|
||||
(case-lambda
|
||||
[() ($current-winders)]
|
||||
[(w)
|
||||
(unless (and (list? w) (andmap (lambda (x) (winder? x)) w))
|
||||
($oops '$current-winders "malformed winders ~s" w))
|
||||
($current-winders w)]))
|
||||
(unless (and (list? w) (andmap winder? w))
|
||||
($oops who "malformed winders ~s" w))
|
||||
($current-winders w)])))
|
||||
|
||||
(define $current-attachments
|
||||
(case-lambda
|
||||
[() ($current-attachments)]
|
||||
[(w)
|
||||
(unless (list? w)
|
||||
($oops '$current-attachments "malformed attachments ~s" w))
|
||||
($current-attachments w)]))
|
||||
|
||||
(define lock-object
|
||||
(foreign-procedure "(cs)lock_object" (scheme-object) void))
|
||||
|
|
|
|||
10
s/types.ss
10
s/types.ss
|
|
@ -109,3 +109,13 @@
|
|||
(define profile-counter-count (record-accessor '#,rtd 0))
|
||||
(define profile-counter-count-set! (record-mutator '#,rtd 0))))]))])
|
||||
(a profile-counter? make-profile-counter profile-counter-count profile-counter-count-set!))
|
||||
|
||||
|
||||
(define-record-type winder
|
||||
(fields (immutable in) (immutable out) (immutable attachments))
|
||||
(nongenerative #{winder qnbz1n5f3x1ldovscan3nu-0}))
|
||||
|
||||
(define-record-type critical-winder
|
||||
(parent winder)
|
||||
(sealed #t)
|
||||
(nongenerative #{critical-winder qnbz1n5f3x1ldovscan3nu-2}))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user