From ac0b1f71cafc829619f9a3e449e0a6cbd4a9f13e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Jul 2020 08:28:27 -0600 Subject: [PATCH] add functions to traverse a continuation without splitting original commit: 0f3ff69d4247ec695087953892839d680ed32fff --- makefiles/Mf-install.in | 2 +- s/cmacros.ss | 2 +- s/cpnanopass.ss | 91 ++++++++++++++++++++++++++++------------- s/primdata.ss | 4 ++ s/prims.ss | 30 ++++++++++++++ 5 files changed, 98 insertions(+), 31 deletions(-) diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index 0ee25d1d73..9ce6714100 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.30 +Version=csv9.5.3.31 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/s/cmacros.ss b/s/cmacros.ss index b25b903102..e1cb5cf64b 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 #x0905031E) +(define-constant scheme-version #x0905031F) (define-syntax define-machine-types (lambda (x) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 6d59dec6c4..8ee4303f8f 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -10173,38 +10173,71 @@ (translate (%mref ,e ,(constant continuation-stack-clength-disp)) (constant fixnum-offset) (constant log2-ptr-bytes))]) - (define-inline 3 $continuation-return-code - [(e) - (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) - (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) - ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) - (%inline - ,t ,(%mref ,t 0))))]) - (define-inline 3 $continuation-return-offset - [(e) - (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) - (build-fix - `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) - ,(%constant compact-return-address-toplink-disp)) - ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) - ,(%constant return-address-toplink-disp)))))]) - (define-inline 3 $continuation-return-livemask - [(e) - (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))]) - (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) - `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) - ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)), - (%constant fixnum-offset)) - ,(%mref ,ra ,(constant return-address-livemask-disp)))))]) - (define-inline 3 $continuation-stack-ref - [(e-k e-i) - (%mref + (let () + (define (build-ra e) + (%mref ,e ,(constant continuation-return-address-disp))) + (define (build-stack-ra e-k e-i) + (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) + ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) + 0)) + + (define build-return-code + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) + ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) + (%inline - ,t ,(%mref ,t 0)))))) + (define build-return-offset + (lambda (e-ra) + (bind #t ([ra e-ra]) + (build-fix + `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) + ,(%constant compact-return-address-toplink-disp)) + ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) + ,(%constant return-address-toplink-disp))))))) + (define build-return-livemask + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-livemask-disp))))))) + (define build-return-frame-words + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline logand ,(%inline srl ,mask+size+mode ,(%constant compact-frame-words-offset)) + ,(%constant compact-frame-words-mask)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-frame-size-disp))))))) + + (define-inline 3 $continuation-return-code + [(e) (build-return-code (build-ra e))]) + (define-inline 3 $continuation-return-offset + [(e) (build-return-offset (build-ra e))]) + (define-inline 3 $continuation-return-livemask + [(e) (build-return-livemask (build-ra e))]) + (define-inline 3 $continuation-return-frame-words + [(e) (build-return-frame-words (build-ra e))]) + (define-inline 3 $continuation-stack-ref + [(e-k e-i) + (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) 0)]) + (define-inline 3 $continuation-stack-return-code + [(e-k e-i) (build-return-code (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-offset + [(e-k e-i) (build-return-offset (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-frame-words + [(e-k e-i) (build-return-frame-words (build-stack-ra e-k e-i))])) + (define-inline 2 $foreign-char? [(e) (bind #t (e) diff --git a/s/primdata.ss b/s/primdata.ss index ca31ebdae5..bd187df1fe 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1870,11 +1870,15 @@ ($continuation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($continuation-link [flags single-valued]) ($continuation-return-code [flags single-valued]) + ($continuation-return-frame-words [flags single-valued]) ($continuation-return-livemask [flags single-valued]) ($continuation-return-offset [flags single-valued]) ($continuation-stack-clength [flags single-valued]) ($continuation-stack-length [flags single-valued]) ($continuation-stack-ref [flags single-valued]) + ($continuation-stack-return-code [flags single-valued]) + ($continuation-stack-return-offset [flags single-valued]) + ($continuation-stack-return-frame-words [flags single-valued]) ($continuation-winders [flags single-valued]) ($continuation-attachments [flags single-valued]) ($cp0 [flags single-valued]) diff --git a/s/prims.ss b/s/prims.ss index b29d2fd35d..856f5853bd 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -616,6 +616,36 @@ ($oops '$continuation-return-offset "~s is not a continuation" x)) ($continuation-return-offset x))) +(define-who $continuation-return-frame-words + (lambda (x) + (unless ($continuation? x) + ($oops who "~s is not a continuation" x)) + ($continuation-return-frame-words x))) + +(define-who $continuation-stack-return-code + (lambda (x i) + (unless ($continuation? x) + ($oops who "~s is not a continuation" x)) + (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x))) + ($oops who "invalid index ~s" i)) + ($continuation-stack-return-code x i))) + +(define-who $continuation-stack-return-offset + (lambda (x i) + (unless ($continuation? x) + ($oops who "~s is not a continuation" x)) + (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x))) + ($oops who "invalid index ~s" i)) + ($continuation-stack-return-offset x i))) + +(define-who $continuation-stack-return-frame-words + (lambda (x i) + (unless ($continuation? x) + ($oops who "~s is not a continuation" x)) + (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x))) + ($oops who "invalid index ~s" i)) + ($continuation-stack-return-frame-words x i))) + (define void (lambda () (void)))