diff --git a/mats/4.ms b/mats/4.ms index de0c8d63b8..d7f44cea61 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -3283,6 +3283,11 @@ (define (returns-not-a-procedure) 'also-something-else) (define (return-three-values) (values 1 2 3)) (define (return-the-same-value v) v) + (define (check-attachments-start v r) + (let ([ats (current-continuation-attachments)]) + (and (pair? ats) + (equal? (car ats) v) + r))) #t) (equal? 'yep (call-with-yep get-or-nope)) (equal? 'yeah (call-with-yep (lambda () (call-with-yeah get-or-nope)))) @@ -3425,6 +3430,31 @@ 'ok (lambda () (call-with-values (lambda () (return-one)) act-like-list)))))) + (equal? '(ok) + (call-with-yep ; just to ensure the argument `lambda` isn't inlined + (lambda () + (call-setting-continuation-attachment + 'ok + (lambda () + ;; Should be detected as a loop form + (let loop ([i 1000]) + (if (fx= i 0) + (current-continuation-attachments) + (loop (sub1 i))))))))) + (equal? 'ok + (call-setting-continuation-attachment + -1 + (lambda () + (let loop ([i 0]) + (cond + [(= i 1000) 'ok] + [else (check-attachments-start + (sub1 i) + (call-setting-continuation-attachment + i + (lambda () + ;; Not detected as a loop, but as a direct call + (loop (add1 i)))))]))))) ) ;;; section 4-7: diff --git a/s/cmacros.ss b/s/cmacros.ss index 3a82382dba..aaa1bb8543 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -2586,7 +2586,6 @@ (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 () diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 103eede8a8..f18c204b37 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -793,11 +793,14 @@ (define-record-type info-call (nongenerative) (parent info) (sealed #t) - (fields src sexpr (mutable check?) pariah? error?) + (fields src sexpr (mutable check?) pariah? error? shift-attachment?) (protocol (lambda (pargs->new) - (lambda (src sexpr check? pariah? error?) - ((pargs->new) src sexpr check? pariah? error?))))) + (case-lambda + [(src sexpr check? pariah? error? shift-attachment?) + ((pargs->new) src sexpr check? pariah? error? shift-attachment?)] + [(src sexpr check? pariah? error?) + ((pargs->new) src sexpr check? pariah? error? #f)])))) (define-record-type info-newframe (nongenerative) (parent info) @@ -844,7 +847,7 @@ [(kill* libspec save-ra?) ((new kill*) libspec save-ra?)])))) - (module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* dorest-intrinsics) + (module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) ; standing on our heads here to avoid referencing registers at ; load time...would be cleaner if registers were immutable, ; i.e., mutable fields (direct and inherited from var) were kept @@ -872,6 +875,10 @@ (intrinsic-return-live* intrinsic) ((intrinsic-get-rv* intrinsic))) ((intrinsic-get-live* intrinsic))))) + (define intrinsic-modify-reg* + (lambda (intrinsic) + (append ((intrinsic-get-rv* intrinsic)) + ((intrinsic-get-kill* intrinsic))))) (define-syntax declare-intrinsic (syntax-rules (unquote) [(_ name entry-name (kill ...) (live ...) (rv ...)) @@ -903,7 +910,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 reify-cc 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 @@ -1564,16 +1571,21 @@ (lambda (mode) (case mode [(non-tail pop) 'pop] - [(tail tail/reified) 'tail/reified])))) + [(tail tail/reified) 'tail/reified]))) + (define info-call->shifting-info-call + (lambda (info) + (make-info-call (info-call-src info) (info-call-sexpr info) + (info-call-check? info) (info-call-pariah? info) (info-call-error? info) + #t)))) (CaseLambdaClause : CaseLambdaClause (cl) -> CaseLambdaClause () - [(clause (,x* ...) ,interface ,[Expr : body 'tail '() -> body]) + [(clause (,x* ...) ,interface ,[Expr : body 'tail -> body]) `(clause (,x* ...) ,interface ,body)]) - (Expr : Expr (ir [mode 'non-tail] [loop-x* '()]) -> Expr () + (Expr : Expr (ir [mode 'non-tail]) -> Expr () [,x (return mode x)] - [(letrec ([,x* ,[le* 'non-tail '() -> le*]] ...) ,[body]) + [(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]))) + [(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 @@ -1586,7 +1598,7 @@ [(non-tail) ;; Push attachment; `body` has been adjusted to pop `(seq (attachment-set push ,e1) ,body)])] - [(call ,info ,mdcl ,pr ,[e1 'non-tail '() -> e1] + [(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))) @@ -1600,58 +1612,32 @@ [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*] ...) + [(call ,info ,mdcl ,[e 'non-tail -> e] ,[e* 'non-tail -> e*] ...) + (let ([info (case mode + [(pop) (info-call->shifting-info-call info)] + [else info])]) + `(call ,info ,mdcl ,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])]) + [(mvlet ,[e 'non-tail -> e] ((,x** ...) ,interface* ,[body*]) ...) + `(mvlet ,e ((,x** ...) ,interface* ,body*) ...)] + [(mvcall ,info ,[e1 'non-tail -> e1] ,[e2 'non-tail -> e2]) + (let ([info (case mode + [(pop) (info-call->shifting-info-call info)] + [else info])]) `(mvcall ,info ,e1 ,e2))] - [(let ([,x* ,[e* 'non-tail '() -> e*]] ...) ,[body]) + [(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)] + [(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]) `(loop ,x (,x* ...) ,body)] [else ($oops who "unexpected Expr ~s" ir)])) @@ -2798,40 +2784,31 @@ ,[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] + [(and + (or (not (info-call-shift-attachment? info)) + ;; 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)))) + (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)) + => (lambda (e) + (let ([e (Expr e)]) + (cond + [(info-call-shift-attachment? info) + (let ([t (make-tmp 't)]) + `(let ([,t ,e]) + (seq + (attachment-set pop) + ,t)))] + [else e])))] [else (let ([e* (map Expr e*)]) ; NB: expand calls through symbol top-level values similarly (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) + (make-info-call (info-call-src info) (info-call-sexpr info) + (info-call-check? info) #t #t + (info-call-shift-attachment? info)) info)]) `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...)))])])) (define-who unhandled-arity @@ -5414,8 +5391,7 @@ (let () (define hand-coded-closure? (lambda (name) - (not (memq name '(nuate nonprocedure-code error-invoke invoke - $shift-attachment))))) + (not (memq name '(nuate nonprocedure-code error-invoke invoke))))) (define-inline 2 $hand-coded [(name) (nanopass-case (L7 Expr) name @@ -5509,18 +5485,6 @@ (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) @@ -9795,13 +9759,16 @@ (let ([x (make-tmp x)]) (set! local* (cons x local*)) x))) + (define make-info-call-like + (lambda (info) + (make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f (info-call-shift-attachment? info)))) (define Mvcall (lambda (info e consumer k) (with-output-language (L10.5 Expr) (nanopass-case (L10.5 Expr) e - [,t (k `(mvcall ,(make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f) #f ,consumer ,t ()))] + [,t (k `(mvcall ,(make-info-call-like info) #f ,consumer ,t ()))] [(values ,info2 ,t* ...) - (k `(mvcall ,(make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f) #f ,consumer ,t* ... ()))] + (k `(mvcall ,(make-info-call-like info) #f ,consumer ,t* ... ()))] [(mvcall ,info ,mdcl ,t0 ,t1* ... (,t* ...)) (k `(mvcall ,info ,mdcl ,t0 ,t1* ... (,t* ... ,consumer)))] [(if ,e0 ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)] @@ -9817,9 +9784,9 @@ (let ([tmp (make-tmp 't)]) `(seq (set! ,tmp ,rhs) - (mvcall ,(make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f) #f ,consumer ,tmp ())))] + (mvcall ,(make-info-call-like info) #f ,consumer ,tmp ())))] [else ; set! & mvset - `(seq ,e ,(k `(mvcall ,(make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f) #f ,consumer ,(%constant svoid) ())))]))))) + `(seq ,e ,(k `(mvcall ,(make-info-call-like info) #f ,consumer ,(%constant svoid) ())))]))))) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) (,local0* ...) ,mcp ,interface ,body) (fluid-let ([local* local0*]) @@ -9828,7 +9795,8 @@ `(clause (,x* ...) (,local* ...) ,mcp ,interface ,body)))]) (Rhs : Rhs (ir) -> Rhs () - [(call ,info ,mdcl ,[t0?] ,[t1*] ...) `(mvcall ,info ,mdcl ,t0? ,t1* ... ())]) + [(call ,info ,mdcl ,[t0?] ,[t1*] ...) + `(mvcall ,info ,mdcl ,t0? ,t1* ... ())]) (Expr : Expr (ir) -> Expr () [(mvcall ,info ,[e] ,[t]) (Mvcall info e t values)] [(set! ,[lvalue] (mvcall ,info ,[e] ,[t])) @@ -10270,12 +10238,38 @@ (and (libspec? x) (eqv? (info-literal-offset info) 0) x))))) + (define add-reify-cc-save + (lambda (live-reg* e) + ;; Save and restore any live registers that may be + ;; damaged by the `reify-cc` instrinsic. Curently, we + ;; accomodate only up to 2 live registers. + (let* ([to-reg* (reg-list %yp %ac1)] + [ref-reg* (list (ref-reg %yp) (ref-reg %ac1))] + [reify-cc-modify-reg* (intrinsic-modify-reg* reify-cc)] + [save-reg* (fold-left (lambda (reg* r) + (cond + [(memq r reg*) reg*] + [(memq r reify-cc-modify-reg*) (cons r reg*)] + [(memq r to-reg*) + ($oops who "can't handle live register for shift-attachment ~s" r)] + [else reg*])) + '() live-reg*)]) + (with-output-language (L13 Effect) + (let loop ([save-reg* save-reg*] [ref-reg* ref-reg*]) + (cond + [(null? save-reg*) e] + [(null? ref-reg*) ($oops who "too many live registers for shift-attachment")] + [else + (%seq + (set! ,(car ref-reg*) ,(car save-reg*)) + ,(loop (cdr save-reg*) (cdr ref-reg*)) + (set! ,(car save-reg*) ,(car ref-reg*)))])))))) (define build-call (with-output-language (L13 Tail) (case-lambda [(t rpl reg* fv* maybe-info mdcl) - (build-call t #f rpl reg* fv* maybe-info mdcl #f)] - [(t cploc rpl reg* fv* maybe-info mdcl consumer?) + (build-call t #f rpl reg* fv* maybe-info mdcl #f (and maybe-info (info-call-shift-attachment? maybe-info)))] + [(t cploc rpl reg* fv* maybe-info mdcl consumer? shift-attachment?) (let () (define set-return-address (lambda (tl) @@ -10291,13 +10285,29 @@ [live-fv* (meta-cond [(real-register? '%ret) fv*] [else (cons (get-fv 0) fv*)])]) - (if consumer? - `(jump ,t (,%ac0 ,live-reg* ... ,live-fv* ...)) - (if argcnt? - `(seq + ((lambda (e) + (cond + [shift-attachment? + `(seq + ,(add-reify-cc-save + (cons (and consumer? %ac0) + (nanopass-case (L13 Triv) t + [,x (cons x live-reg*)] + [(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! ,%ts ,(%mref ,%td ,(constant continuation-attachments-disp))) + (set! ,(%mref ,%td ,(constant continuation-attachments-disp)) ,(%mref ,%ts ,(constant pair-cdr-disp))))) + ,e)] + [else e])) + (if consumer? + `(jump ,t (,%ac0 ,live-reg* ... ,live-fv* ...)) + (if argcnt? + `(seq (set! ,%ac0 (immediate ,(fx+ (length reg*) (length fv*)))) (jump ,t (,%ac0 ,live-reg* ... ,live-fv* ...))) - `(jump ,t (,live-reg* ... ,live-fv* ...))))))) + `(jump ,t (,live-reg* ... ,live-fv* ...)))))))) (define direct-call (lambda () (if rpl @@ -10328,7 +10338,8 @@ (if mdcl (set-cp ,(ref-reg %cp) ,(or cploc (Triv t)) ,(set-return-address - (if (memq mdcl dcl*) + (if (and (memq mdcl dcl*) + (not shift-attachment?)) (direct-call) (finish-call #f ; don't set the argcount, since it doesn't need to be checked #t (in-context Triv `(label-ref ,mdcl 0)))))) @@ -10351,7 +10362,8 @@ (%mref ,%xp ,(constant closure-code-disp))))))))])))) (if (not t) (set-return-address - (if (memq mdcl dcl*) + (if (and (memq mdcl dcl*) + (not shift-attachment?)) (direct-call) (finish-call #f #f (in-context Triv `(label-ref ,mdcl 0))))) (nanopass-case (L12 Triv) t @@ -10386,13 +10398,13 @@ [else (normal-call)])] [else (normal-call)])))]))) (define build-consumer-call - (lambda (tc cnfv rpl) + (lambda (tc cnfv rpl shift-attachment?) ; haven't a clue which argument registers are live, so list 'em all. ; also haven't a clue which frame variables are live. really need a ; way to list all of them as well, but we count on there being enough ; other registers (e.g., ac0, xp) to get us from the producer return ; point to the consumer jump point. - (build-call tc cnfv rpl arg-registers '() #f #f #t))) + (build-call tc cnfv rpl arg-registers '() #f #f #t shift-attachment?))) (define prepare-for-consumer-call (lambda (mrvl) (with-output-language (L13 Effect) @@ -10452,12 +10464,12 @@ ,(let ([tc (car tc*)] [tc* (cdr tc*)] [rpl* (cdr rpl*)] [cnfv (car cnfv*)] [cnfv* (cdr cnfv*)]) (if (null? tc*) (build-return-point rpl mrvl cnfv* - (build-consumer-call tc cnfv rpl)) + (build-consumer-call tc cnfv rpl (info-call-shift-attachment? info))) (let ([this-mrvl (make-local-label 'mrvl)]) `(seq ,(let ([rpl (car rpl*)]) (build-return-point rpl this-mrvl cnfv* - (build-consumer-call tc cnfv rpl))) + (build-consumer-call tc cnfv rpl (info-call-shift-attachment? info)))) ,(f tc* cnfv* rpl* this-mrvl))))))))))) ,(build-postlude newframe-info)))))))))))) ; NB: combine @@ -10505,12 +10517,12 @@ ,(let ([tc (car tc*)] [tc* (cdr tc*)] [rpl* (cdr rpl*)] [cnfv (car cnfv*)] [cnfv* (cdr cnfv*)]) (if (null? (cdr tc*)) (build-return-point rpl mrvl cnfv* - (build-consumer-call tc cnfv rpl)) + (build-consumer-call tc cnfv rpl (info-call-shift-attachment? info))) (let ([this-mrvl (make-local-label 'mrvl)]) `(seq ,(let ([rpl (car rpl*)]) (build-return-point rpl this-mrvl cnfv* - (build-consumer-call tc cnfv rpl))) + (build-consumer-call tc cnfv rpl (info-call-shift-attachment? info)))) ,(f tc* cnfv* rpl* this-mrvl))))))))))) ,(build-postlude newframe-info (car (last-pair cnfv*)))))))))))))) (module (build-tail-call build-mv-return) @@ -10566,7 +10578,7 @@ (restore-local-saves ,newframe-info) (set! ,(ref-reg %cp) ,cnfv) ,(build-shift-args newframe-info)))) - ,(build-consumer-call tc (in-context Triv (ref-reg %cp)) #f)) + ,(build-consumer-call tc (in-context Triv (ref-reg %cp)) #f #f)) (let ([tc* (list-head tc* (fx- (length tc*) 1))]) `(seq ,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #t @@ -10575,7 +10587,7 @@ (remove-frame ,newframe-info) (restore-local-saves ,newframe-info) ,(build-shift-args newframe-info)))) - ,(build-consumer-call tc #f #f)))))))) + ,(build-consumer-call tc #f #f #f)))))))) (define build-mv-return (lambda (t*) (let-values ([(reg* reg-t* frame-t*) (get-arg-regs t*)]) @@ -12424,32 +12436,6 @@ (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)) diff --git a/s/library.ss b/s/library.ss index 7527a50c67..ac19562d3c 100644 --- a/s/library.ss +++ b/s/library.ss @@ -125,7 +125,6 @@ (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)) diff --git a/s/primdata.ss b/s/primdata.ss index e4c8a97fcc..060e018e6e 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -2092,7 +2092,6 @@ ($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]) diff --git a/s/prims.ss b/s/prims.ss index 8e60f81585..87b0b736a0 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -378,12 +378,6 @@ ($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)))