avoid closure
original commit: e3fc13f2b5a5314bfb88e813fc8d0158ddf70ff5
This commit is contained in:
Matthew Flatt
parent
73e4ea603f
commit
f19dd5f010
30
mats/4.ms
30
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:
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
274
s/cpnanopass.ss
274
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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user