diff --git a/BUILDING b/BUILDING index 1a7b85ddc2..a25e558867 100644 --- a/BUILDING +++ b/BUILDING @@ -15,6 +15,14 @@ limitations under the License. ---------------------------------------------------------------------------- +This variant of Chez Scheme is patched for Racket. It doesn't include +boot files; instead, Racket can generate initial boot files from Chez +Scheme's source. For more information, see "racket/src/cs/README.txt" +in Racket sources. After you have boot files, then the directions below +should work. + +---------------------------------------------------------------------------- + This directory contains the sources for Chez Scheme, plus boot and header files for various supported machine types. diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index fe5ea645c7..ebb2019732 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.3 +Version=csv9.5.3.4 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/s/cmacros.ss b/s/cmacros.ss index de21a1e3fd..bf5f6b0d8c 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -328,7 +328,7 @@ [(_ foo e1 e2) e1] ... [(_ bar e1 e2) e2]))))]))) -(define-constant scheme-version #x09050303) +(define-constant scheme-version #x09050304) (define-syntax define-machine-types (lambda (x) @@ -2656,7 +2656,8 @@ (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) + (reify-1cc #f 0 #f #f) + (maybe-reify-cc #f 0 #f #f) (dofretu8* #f 1 #f #f) (dofretu16* #f 1 #f #f) (dofretu32* #f 1 #f #f) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 58b12d3ebb..9ede13e870 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -910,7 +910,8 @@ (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%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) () (%td)) + (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts) () (%td)) + (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts) () (%td)) (declare-intrinsic dooverflow dooverflow () () ()) (declare-intrinsic dooverflood dooverflood () (%xp) ()) ; a dorest routine takes all of the register and frame arguments from the rest @@ -1657,6 +1658,19 @@ [else ;; Check dynamically for attachment, and also reify for tail `(let ([,x (attachment-consume ,e1)]) ,body)])] + [(call ,info ,mdcl ,pr + (case-lambda ,info2 (clause (,x) ,interface ,[body mode -> body]))) + (guard (and (memq mode '(tail tail/none tail/some)) + (eq? (primref-name pr) 'call/cc) + (= interface 1))) + ;; Since we're in tail position, we can just reify the continuation and + ;; put the stack link in the argument variable. + (let ([cop (case mode + [(tail/some tail/none) + ;; Already reified + 'get] + [else 'reify])]) + `(let ([,x (continuation-get ,cop)]) ,body))] [(call ,info ,mdcl ,[e 'non/none -> e] ,[e* 'non/none -> e*] ...) (let ([info (case mode [(non/some) (info-call->shifting-info-call info)] @@ -2204,7 +2218,7 @@ b*) c)))))) (module (make-bank deposit retain borrow) - ; NB: borrowing is probably cubic at present + ; NB: borrowing is probably cubic at pre Tail () [(inline ,info ,prim ,[t*] ...) (guard (pred-primitive? prim)) @@ -10668,11 +10686,11 @@ x))))) (define add-reify-cc-save (lambda (live-reg* e) - ;; Save and restore any live registers that may be used by the `reify-cc` instrinsic. + ;; Save and restore any live registers that may be used by the `reify-1cc` instrinsic. ;; Since we can't use temporaries at this point --- %sfp is already moved --- manually ;; allocate a few registers (that may not be real registers) and hope that we ;; have enough. - (let* ([reify-cc-modify-reg* (intrinsic-modify-reg* reify-cc)] + (let* ([reify-cc-modify-reg* (intrinsic-modify-reg* reify-1cc)] [tmp-reg* (reg-list %ac1 %yp)] [save-reg* (fold-left (lambda (reg* r) (cond @@ -10729,7 +10747,7 @@ [(mref ,x1 ,x2 ,imm) (cons x1 (cons x2 live-reg*))] [else live-reg*])) (%seq - (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall)) + (set! ,%td (inline ,(intrinsic-info-asmlib reify-1cc #f) ,%asmlibcall)) (set! ,%ts ,(%mref ,%td ,(constant continuation-attachments-disp))) (set! ,(%mref ,%td ,(constant continuation-attachments-disp)) ,(%mref ,%ts ,(constant pair-cdr-disp))))) ,e)] @@ -11788,7 +11806,7 @@ `(set! ,lvalue ,t) (%seq (set! ,lvalue ,t) - (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall)))) + (set! ,%td (inline ,(intrinsic-info-asmlib reify-1cc #f) ,%asmlibcall)))) ;; Reified with attachment ,(let ([get `(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))]) (if consume? @@ -11801,7 +11819,7 @@ `(set! ,lvalue ,t) (%seq (set! ,lvalue ,t) - (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall)))))))))) + (set! ,%td (inline ,(intrinsic-info-asmlib reify-1cc #f) ,%asmlibcall)))))))))) (Program : Program (ir) -> Program () [(labels ([,l* ,le*] ...) ,l) `(labels ([,l* ,(map CaseLambdaExpr le* l*)] ...) ,l)]) @@ -11827,17 +11845,18 @@ [(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) + [(reify-1cc maybe-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 () + (reg-list %xp %td %ac0 %ts))] + [1cc? (eq? sym 'reify-1cc)]) + `(lambda ,(make-named-info-lambda (if 1cc? "reify-1cc" "maybe-reify-cc") '(0)) 0 () ,(asm-enter (%seq (check-live ,other-reg* ...) - ,(reify-cc-help #t #t + ,(reify-cc-help 1cc? 1cc? (lambda (reg) (if (eq? reg %td) `(asm-return ,%td ,other-reg* ...) @@ -11997,7 +12016,9 @@ [(attachment-get ,t* ...) ($oops who "Effect is responsible for handling attachment-gets")] [(attachment-consume ,t* ...) - ($oops who "Effect is responsible for handling attachment-consumes")]) + ($oops who "Effect is responsible for handling attachment-consumes")] + [(continuation-get ,cop) + ($oops who "Effect is responsible for handling continuatio-get")]) (Effect : Effect (ir) -> Effect () [(do-rest ,fixed-args) (if (fx<= fixed-args dorest-intrinsic-max) @@ -12115,10 +12136,18 @@ (if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats) (nop) (set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp)))) - (set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))) + (set! ,%td (inline ,(intrinsic-info-asmlib reify-1cc #f) ,%asmlibcall))) ,(make-push)))] [else - ($oops who "unexpected attachment-set mode ~s" aop)]))]) + ($oops who "unexpected attachment-set mode ~s" aop)]))] + [(set! ,[lvalue] (continuation-get ,cop)) + (case cop + [(get) `(set! ,lvalue ,(%tc-ref stack-link))] + [(reify) (%seq + (set! ,%td (inline ,(intrinsic-info-asmlib maybe-reify-cc #f) ,%asmlibcall)) + (set! ,lvalue ,%td))] + [else + ($oops who "unexpected continuation-set mode ~s" cop)])]) (Tail : Tail (ir) -> Tail () [(entry-point (,x* ...) ,dcl ,mcp ,tlbody) (unless (andmap (lambda (x) (eq? (uvar-type x) 'ptr)) x*) diff --git a/s/library.ss b/s/library.ss index 2cc8c91fc2..a677378ec2 100644 --- a/s/library.ss +++ b/s/library.ss @@ -112,7 +112,8 @@ ;;; 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 reify-1cc) +(define-hand-coded-library-entry maybe-reify-cc) (define-hand-coded-library-entry callcc) (define-hand-coded-library-entry call1cc) (define-hand-coded-library-entry dofargint32) diff --git a/s/np-languages.ss b/s/np-languages.ss index fbcd3a8a58..eec72191e5 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -387,15 +387,21 @@ (lambda (x) (memq x '(push pop set reify-and-set)))) + (define continuation-op? + (lambda (x) + (memq x '(get reify)))) + ; exposes continuation-attachment operations (define-language L4.9375 (extends L4.875) (terminals - (+ (attachment-op (aop)))) + (+ (attachment-op (aop)) + (continuation-op (cop)))) (entry CaseLambdaExpr) (Expr (e body) (+ (attachment-set aop e* ...) (attachment-get e* ...) - (attachment-consume e* ...)))) + (attachment-consume e* ...) + (continuation-get cop)))) ; moves all case lambda expressions into rhs of letrec (define-language L5 (extends L4.9375) @@ -672,7 +678,8 @@ (mvcall info e t) => (mvcall e t) (foreign-call info t t* ...) (attachment-get t* ...) - (attachment-consume t* ...))) + (attachment-consume t* ...) + (continuation-get cop))) (Expr (e body) (- lvalue (values info e* ...) @@ -687,7 +694,8 @@ (mvcall info e1 e2) (foreign-call info e e* ...) (attachment-get e* ...) - (attachment-consume e* ...)) + (attachment-consume e* ...) + (continuation-get cop)) (+ rhs (values info t* ...) (set! lvalue rhs))))