From 1baa0da9919603f16ae1cc898d06b160dcde562c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 8 Feb 2019 13:57:14 -0800 Subject: [PATCH] use opportunistic 1-shot continuations for attachments An attachment continuation link can be a 1-shot continuation, but the existing 1-short continuation implementation tends to work less well than mutishot continuations. An opportunistic 1-shot continuation is like a multi-shot continuation, but if it is called from a stack that is adjacent to the continuation, then the stack is merged with the continuation's stack. original commit: ea1eb3c5192d644ad4c4cbf755bcb6fd438cc364 --- c/gc.c | 7 ++- s/cmacros.ss | 5 ++ s/cpnanopass.ss | 130 ++++++++++++++++++++++++++++-------------------- 3 files changed, 85 insertions(+), 57 deletions(-) diff --git a/c/gc.c b/c/gc.c index 42294a9362..afc1da900e 100644 --- a/c/gc.c +++ b/c/gc.c @@ -600,8 +600,11 @@ static ptr copy(pp, si) ptr pp; seginfo *si; { find_room(space_continuation, tg, type_closure, size_continuation, p); SETCLOSCODE(p,code); - /* don't promote one-shots */ - CONTLENGTH(p) = CONTLENGTH(pp); + /* don't promote general one-shots, but do promote opportunistic one-shots */ + if (CONTLENGTH(pp) == opportunistic_1_shot_flag) + CONTLENGTH(p) = CONTCLENGTH(pp); + else + CONTLENGTH(p) = CONTLENGTH(pp); CONTCLENGTH(p) = CONTCLENGTH(pp); CONTWINDERS(p) = CONTWINDERS(pp); CONTATTACHMENTS(p) = CONTATTACHMENTS(pp); diff --git a/s/cmacros.ss b/s/cmacros.ss index 111bb97f5c..5d2e36d1a2 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -1915,6 +1915,11 @@ (define-constant unscaled-shot-1-shot-flag -1) (define-constant scaled-shot-1-shot-flag (* (constant unscaled-shot-1-shot-flag) (constant ptr-bytes))) +;; opportunistic--1-shot-flag is in the continuation length field for +;; a one-shot continuation that is only treated a 1-shot when +;; it's contiguous with the current stack when called, in which case +;; the continuation can be just merged back with the current stack +(define-constant opportunistic-1-shot-flag 0) ;;; underflow limit determines how much we're willing to copy on ;;; stack underflow/continuation invocation diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 783e9efcfc..b747dbd9b8 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -11485,8 +11485,27 @@ (goto ,Lcopy-stack))) ,load-xp/cp (goto ,Lreturn))) - ; 1 shot - ,(%seq + ; 1 shot, possibly opportunistic + (if ,(%inline eq? + ,(%mref ,xp/cp ,(constant continuation-stack-length-disp)) + (immediate ,(constant opportunistic-1-shot-flag))) + ; opportunistic 1-shot, so merge with the current stack if possible, + ; otherwise just treat as multishot + ,(%seq + (set! ,%ts ,(%inline + ,%td ,(%mref ,xp/cp ,(constant continuation-stack-disp)))) + (if ,(%inline eq? ,%sfp ,%ts) + ; merge, and we assume that the stack link includes attachments + ,(%seq + (set! ,(%tc-ref scheme-stack-size) ,(%inline + ,%td ,(%tc-ref scheme-stack-size))) + (set! ,(%tc-ref scheme-stack) ,(%mref ,xp/cp ,(constant continuation-stack-disp))) + (set! ,(%tc-ref stack-link) ,(%mref ,xp/cp ,(constant continuation-link-disp))) + (set! ,%ts ,(%mref ,xp/cp ,(constant continuation-attachments-disp))) + (set! ,(%tc-ref attachments) ,%ts) + (goto ,Lreturn)) + ; can't merge + (goto ,Lmultishot))) + ; General 1-shot + ,(%seq ; treat as multishot if clength + size(values) > length ; conservative: some values may be in argument registers ; AWK - very carefully using ts here as we are out of other registers @@ -11553,52 +11572,62 @@ (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) + (lambda (1-shot? 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))))))))) + ,(let ([build-reify + (lambda () + (%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)) + ,(if 1-shot? + `(immediate ,(constant opportunistic-1-shot-flag)) + %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)))))]) + (if 1-shot? + (build-reify) + ;; Promote existing 1-shot to multishot before reifying + (let ([Ltop (make-local-label 'Ltop)]) + (%seq + (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) + ,(build-reify) + ,(%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)]) @@ -11634,7 +11663,7 @@ ,(asm-enter (%seq (check-live ,other-reg* ...) - ,(reify-cc-help + ,(reify-cc-help #t (lambda (reg) (if (eq? reg %td) `(asm-return ,%td ,other-reg* ...) @@ -11642,19 +11671,10 @@ (set! ,%td ,reg) (asm-return ,%td ,other-reg* ...)))))))))] [(callcc) - ;; 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)) - ,(reify-cc-help + ,(reify-cc-help #f (lambda (reg) (%seq (set! ,(make-arg-opnd 1) ,reg)