suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

semi-inline call/cc in tail position

Browse Source 
Effectively, change a `call/cc` call to `let/cc` when it appears in
the tail position of a function. This change takes advantage of
continuation-reification support that was built for continuation
attachments.

original commit: 4c015a5b55f7d04839a0efd8e5554fc237e4663b
This commit is contained in:
Matthew Flatt 2019-10-23 08:31:50 -06:00
parent bed6036b26
commit f52283de7e
6 changed files with 70 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
BUILDING
View File

@ -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.

2
makefiles/Mf-install.in
View File

@ -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

5
s/cmacros.ss
View File

@ -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)

59
s/cpnanopass.ss
View File

@ -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<sent
; might should represent bank as a prefix tree
(define sort-free
(lambda (free*)
@ -10090,6 +10104,7 @@
(Triv* e*
(lambda (t*)
(k `(attachment-set ,aop ,t* ...))))]
[(continuation-get ,cop) (k `(continuation-get ,cop))]
[(foreign-call ,info ,e0 ,e1* ...)
(Triv* (cons e0 e1*)
(lambda (t*)
@ -10451,6 +10466,8 @@
`(set! ,lvalue (attachment-get ,t* ...))]
[(set! ,[lvalue] (attachment-consume ,[t*] ...))
`(set! ,lvalue (attachment-consume ,t* ...))]
[(set! ,[lvalue] (continuation-get ,cop))
`(set! ,lvalue (continuation-get ,cop))]
[(label ,l ,[ebody]) `(seq (label ,l) ,ebody)]
[(trap-check ,ioc ,[ebody]) `(seq (trap-check ,ioc) ,ebody)]
[(overflow-check ,[ebody]) `(seq (overflow-check) ,ebody)]
@ -10469,7 +10486,8 @@
,(f `(seq (label ,(car l*)) ,(car e*)) (cdr l*) (cdr e*)))))
(label ,join)))]
[(values ,info ,t* ...) `(nop)]
[(attachment-get ,t* ...) `(nop)])
[(attachment-get ,t* ...) `(nop)]
[(continuation-get ,cop) `(nop)])
(Tail : Expr (ir) -> 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*)

3
s/library.ss
View File

@ -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)

16
s/np-languages.ss
View File

@ -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))))