cptypes: add support for call-with-values, apply and similar functions
In some procedures, one of the arguments is a function that will surely be called and the result is the result of the whole expression. These procedures need an special version of define-specialize that gives more control. original commit: f2f0401d2b83313e8cb0d5742e89ed098500cbd6
This commit is contained in:
Gustavo Massaccesi
parent
c581cd24fe
commit
24be6703bf
|
|
@ -2255,10 +2255,10 @@
|
|||
(equivalent-expansion?
|
||||
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
;; don't fold primitive in test context with bad apply convention
|
||||
(expand/optimize '(if (#%apply #%eof-object 1 2 3) 4 5)))
|
||||
(expand/optimize '(if (#%apply #%pair? 1 2 3) 4 5)))
|
||||
(if (= (optimize-level) 3)
|
||||
'(if (#3%apply #3%eof-object 1 2 3) 4 5)
|
||||
'(if (#2%apply #2%eof-object 1 2 3) 4 5)))
|
||||
'(if (#3%apply #3%pair? 1 2 3) 4 5)
|
||||
'(if (#2%apply #2%pair? 1 2 3) 4 5)))
|
||||
(equivalent-expansion?
|
||||
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
;; don't fold primitive in effect context with bad apply convention
|
||||
|
|
|
|||
355
mats/cptypes.ms
355
mats/cptypes.ms
|
|
@ -704,3 +704,358 @@
|
|||
'(lambda (b) (list (unbox b) (lambda (x) (box? b))))
|
||||
'(lambda (b) (list (unbox b) (lambda (x) #t))))
|
||||
)
|
||||
|
||||
(mat cptypes-call-with-values
|
||||
; The single value case is handled by cp0
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (v)
|
||||
(call-with-values
|
||||
(lambda () (vector-ref v 0))
|
||||
(lambda (y) (list (vector? v) (vector-ref v 1) y))))
|
||||
'(lambda (v)
|
||||
(call-with-values
|
||||
(lambda () (vector-ref v 0))
|
||||
(lambda (y) (list #t (vector-ref v 1) y)))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t)
|
||||
(call-with-values
|
||||
(lambda () (if t (box 2) (box 3)))
|
||||
(lambda (y) (list y (box? y)))))
|
||||
'(lambda (t)
|
||||
(call-with-values
|
||||
(lambda () (if t (box 2) (box 3)))
|
||||
(lambda (y) (list y #t)))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 2))
|
||||
(lambda (y) (display (unbox b))))
|
||||
(box? b))
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 2))
|
||||
(lambda (y) (display (unbox b))))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 2))
|
||||
(lambda (y) (display y)))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 2))
|
||||
(lambda (y) (display y)))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 (values 2 3)))
|
||||
(lambda (x y) (list x y (box? b)))))
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 (values 2 3)))
|
||||
(lambda (x y) (list x y #t)))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(lambda (x y) (display (list x y (unbox b)))))
|
||||
(box? b))
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(lambda (x y) (display (list x y (unbox b)))))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 (values 2 3)))
|
||||
(lambda (x y) (display (list x y))))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(lambda () (if (unbox b) 1 (values 2 3)))
|
||||
(lambda (x y) (display (list x y))))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(case-lambda
|
||||
[() (if (unbox b) 1 (values 2 3))]
|
||||
[(x) (error 'e "")])
|
||||
(lambda (x y) (list x y (box? b)))))
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(case-lambda
|
||||
[() (if (unbox b) 1 (values 2 3))]
|
||||
[(x) (error 'e "")])
|
||||
(lambda (x y) (list x y #t)))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda
|
||||
[(x y) (display (list x y (unbox b)))]
|
||||
[(x) (error 'e "")]))
|
||||
(box? b))
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda
|
||||
[(x y) (display (list x y (unbox b)))]
|
||||
[(x) (error 'e "")]))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(case-lambda
|
||||
[() (if (unbox b) 1 (values 2 3))]
|
||||
[(x) (error 'e "")])
|
||||
(lambda (x y) (display (list x y))))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(call-with-values
|
||||
(case-lambda
|
||||
[() (if (unbox b) 1 (values 2 3))]
|
||||
[(x) (error 'e "")])
|
||||
(lambda (x y) (display (list x y))))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
|
||||
(lambda (x y) (list x y (box? b)))))
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(begin (display (unbox b)) (lambda () (if t 1 (values b 2))))
|
||||
(lambda (x y) (list x y #t)))))
|
||||
; This is difficult to handle in cptypes, so I ignored it.
|
||||
; But it is anyway handled by cp0.
|
||||
#;(cptypes-equivalent-expansion?
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values b (box? b))))
|
||||
(begin (display (unbox b)) (lambda (x y) (list x y b)))))
|
||||
'(lambda (t b)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values b #t)))
|
||||
(begin (display (unbox b)) (lambda (x y) (list x y b))))))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t)
|
||||
(number?
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda [(x y) 2] [(x) 1]))))
|
||||
'(lambda (t)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda [(x y) 2] [(x) 1]))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t)
|
||||
(number?
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda [(x y) 2] [(x) (error 'e "")]))))
|
||||
'(lambda (t)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
(case-lambda [(x y) 2] [(x) (error 'e "")]))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t f)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
f)
|
||||
(procedure? f))
|
||||
'(lambda (t f)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
f)
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t f)
|
||||
(call-with-values
|
||||
f
|
||||
(lambda (x y) (+ x y)))
|
||||
(procedure? f))
|
||||
'(lambda (t f)
|
||||
(call-with-values
|
||||
f
|
||||
(lambda (x y) (+ x y)))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
f)
|
||||
111))
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(call-with-values
|
||||
(lambda () (if t 1 (values 2 3)))
|
||||
f)
|
||||
222)))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(call-with-values
|
||||
f
|
||||
(lambda (x y) (+ x y)))
|
||||
111))
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(call-with-values
|
||||
f
|
||||
(lambda (x y) (+ x y)))
|
||||
222)))
|
||||
)
|
||||
|
||||
(mat cptypes-apply
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x) (display (list (unbox b) x))) l)
|
||||
(box? b))
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x) (display (list (unbox b) x))) l)
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x y) (display (list (unbox b) x))) 7 l)
|
||||
(box? b))
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x y) (display (list (unbox b) x))) 7 l)
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x) (display (list b x))) (unbox b))
|
||||
(box? b))
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x) (display (list b x))) (unbox b))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x y) (display (list b x y))) 7 (unbox b))
|
||||
(box? b))
|
||||
'(lambda (l b)
|
||||
(apply (lambda (x y) (display (list b x y))) 7 (unbox b))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
; with #3% the argument may be inlined and then executed in reverse order
|
||||
'(lambda (l b)
|
||||
(#2%apply (lambda (x y) (list (box? b) x y)) 7 (unbox b)))
|
||||
'(lambda (l b)
|
||||
(#2%apply (lambda (x y) (list #t x y)) 7 (unbox b))))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l b)
|
||||
(apply
|
||||
(case-lambda
|
||||
[(x) (list (unbox b) x)]
|
||||
[(x y) (error 'e "")])
|
||||
l)
|
||||
(box? b))
|
||||
'(lambda (l b)
|
||||
(apply
|
||||
(case-lambda
|
||||
[(x) (list (unbox b) x)]
|
||||
[(x y) (error 'e "")])
|
||||
l)
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l)
|
||||
(number?
|
||||
(apply (lambda (x y) (+ x y)) l)))
|
||||
'(lambda (l)
|
||||
(apply (lambda (x y) (+ x y)) l)
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (l)
|
||||
(number?
|
||||
(apply
|
||||
(case-lambda
|
||||
[(x y) (+ x y)]
|
||||
[() (error 'e "")])
|
||||
l)))
|
||||
'(lambda (l)
|
||||
(apply
|
||||
(case-lambda
|
||||
[(x y) (+ x y)]
|
||||
[() (error 'e "")])
|
||||
l)
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (f l)
|
||||
(apply f l)
|
||||
(procedure? f))
|
||||
'(lambda (f l)
|
||||
(apply f l)
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(apply f l)
|
||||
111))
|
||||
'(lambda (t f)
|
||||
(when (box? f)
|
||||
(apply f l)
|
||||
222)))
|
||||
)
|
||||
|
||||
(mat cptypes-dynamic-wind
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (f)
|
||||
(box? (dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))))
|
||||
'(lambda (f)
|
||||
(begin
|
||||
(dynamic-wind (lambda (x) #f) (lambda () (box (f))) (lambda () #f))
|
||||
#t)))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #f))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) #f) (lambda () (unbox b)) (lambda () #f))
|
||||
#t))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
|
||||
(box? b))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) #f) (lambda () #f) (lambda () (unbox b)))
|
||||
#t))
|
||||
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () (box? b)) (lambda () #f)))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () #t) (lambda () #f))))
|
||||
(cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () (box? b))))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda (x) (unbox b)) (lambda () #f) (lambda () #t) )))
|
||||
(not (cptypes-equivalent-expansion?
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () (box? b))))
|
||||
'(lambda (b)
|
||||
(dynamic-wind (lambda () #f) (lambda (x) (unbox b)) (lambda () #t)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1671,6 +1671,8 @@
|
|||
(safeongoodargs #b00100000000000000000000)
|
||||
(cptypes2 #b01000000000000000000000)
|
||||
(cptypes3 cptypes2)
|
||||
(cptypes2x cptypes2)
|
||||
(cptypes3x cptypes2)
|
||||
(arith-op (or proc pure true))
|
||||
(alloc (or proc discard true))
|
||||
; would be nice to check that these and only these actually have cp0 partial folders
|
||||
|
|
|
|||
167
s/cptypes.ss
167
s/cptypes.ss
|
|
@ -776,6 +776,74 @@ Notes:
|
|||
body))])
|
||||
($sputprop 'prim 'key handler)) ...)))])))
|
||||
|
||||
; Similar to define-specialize, but the arguments are not analyzed yet,
|
||||
; so it's necesary to use Expr, Expr/call or a similar function to analyze them.
|
||||
; Also, the variables ret, ntypes and (get-type <arg>) are not available.
|
||||
(define-syntax define-specialize/unrestricted
|
||||
(lambda (x)
|
||||
(define (make-get-type-name id)
|
||||
(datum->syntax-object id
|
||||
(gensym (string-append (symbol->string (syntax->datum id))
|
||||
"-ret-type"))))
|
||||
(syntax-case x ()
|
||||
[(_key lev prim clause ...)
|
||||
(identifier? #'prim)
|
||||
#'(_key lev (prim) clause ...)]
|
||||
[(_key lev (prim ...) clause ...)
|
||||
(andmap identifier? #'(prim ...))
|
||||
(with-implicit (_key level prim-name preinfo pr ctxt oldtypes)
|
||||
(with-syntax
|
||||
([key (case (datum lev)
|
||||
[(2) #'cptypes2x]
|
||||
[(3) #'cptypes3x]
|
||||
[else ($oops #f "invalid inline level ~s" (datum lev))])]
|
||||
[body
|
||||
(let loop ([clauses #'(clause ...)])
|
||||
(if (null? clauses)
|
||||
#'(unhandled preinfo pr e* ctxt oldtypes)
|
||||
(with-syntax ((rest (loop (cdr clauses))))
|
||||
(syntax-case (car clauses) ()
|
||||
[((x ...) b1 b2 ...)
|
||||
#;guard: (andmap identifier? #'(x ...))
|
||||
(with-syntax ([n (length #'(x ...))])
|
||||
#'(if (eq? count n)
|
||||
(apply (lambda (x ...)
|
||||
b1 b2 ...) e*)
|
||||
rest))]
|
||||
[(r b1 b2 ...)
|
||||
#;guard: (identifier? #'r)
|
||||
#'(apply
|
||||
(lambda r
|
||||
b1 b2 ...) e*)]
|
||||
[((x ... . r) b1 b2 ...)
|
||||
#;guard: (and (andmap identifier? #'(x ...)) (identifier? #'r))
|
||||
(with-syntax ([n (length #'(x ...))])
|
||||
#'(if (fx>= count n)
|
||||
(apply
|
||||
(lambda (x ... . r)
|
||||
b1 b2 ...) e*)
|
||||
rest))]))))])
|
||||
(for-each
|
||||
(lambda (sym-name)
|
||||
(let ([sym-key (datum key)])
|
||||
(if (getprop sym-name sym-key #f)
|
||||
(warningf #f "duplicate ~s handler for ~s" sym-key sym-name)
|
||||
(putprop sym-name sym-key #t))
|
||||
(unless (all-set?
|
||||
(case (datum lev)
|
||||
[(2) (prim-mask cptypes2x)]
|
||||
[(3) (prim-mask cptypes3x)])
|
||||
($sgetprop sym-name '*flags* 0))
|
||||
(warningf #f "undeclared ~s handler for ~s~%" sym-key sym-name))))
|
||||
(datum (prim ...)))
|
||||
#'(begin
|
||||
(let ([handler (lambda (preinfo pr e* ctxt oldtypes unhandled)
|
||||
(let ([level (if (all-set? (prim-mask unsafe) (primref-flags pr)) 3 2)]
|
||||
[prim-name 'prim]
|
||||
[count (length e*)])
|
||||
body))])
|
||||
($sputprop 'prim 'key handler)) ...)))])))
|
||||
|
||||
(define-syntax (get-type stx)
|
||||
(lambda (lookup)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -859,6 +927,84 @@ Notes:
|
|||
[else
|
||||
(values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))])
|
||||
|
||||
(define-specialize/unrestricted 2 call-with-values
|
||||
[(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1)
|
||||
(Expr/call e1 'value oldtypes oldtypes)])
|
||||
(let-values ([(e2 ret2 types2 t-types2 f-types2)
|
||||
(Expr/call e2 ctxt types1 oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,e1 ,e2)
|
||||
(if (predicate-implies? ret1 'bottom) ; check if necesary
|
||||
'bottom
|
||||
ret2)
|
||||
types2 t-types2 f-types2)))])
|
||||
|
||||
(define-specialize/unrestricted 2 apply
|
||||
[(proc . e*) (let-values ([(e* r* t* t-t* f-t*)
|
||||
(map-values 5 (lambda (e) (Expr e 'value oldtypes)) e*)])
|
||||
(let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)])
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
||||
(Expr/call proc ctxt mtypes oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,proc ,e* ...)
|
||||
retproc typesproc t-typesproc f-typesproc))))])
|
||||
|
||||
(define-specialize/unrestricted 2 $apply
|
||||
[(proc n args) (let*-values ([(n rn tn t-tn f-tn)
|
||||
(Expr n 'value oldtypes)]
|
||||
[(args rargs targs t-targs f-targs)
|
||||
(Expr args 'value oldtypes)])
|
||||
(let* ([predn (primref->argument-predicate pr 1 #t)]
|
||||
[tn (if (predicate-implies-not? rn predn)
|
||||
'bottom
|
||||
tn)]
|
||||
[tn (pred-env-add/ref tn n predn)]
|
||||
[predargs (primref->argument-predicate pr 2 #t)]
|
||||
[targs (if (predicate-implies-not? rargs predargs)
|
||||
'bottom
|
||||
targs)]
|
||||
[targs (pred-env-add/ref targs args predargs)]
|
||||
[mtypes (pred-env-intersect/base tn targs oldtypes)])
|
||||
(let-values ([(proc retproc typesproc t-typesproc f-typesproc)
|
||||
(Expr/call proc ctxt mtypes oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,proc ,n ,args)
|
||||
retproc typesproc t-typesproc f-typesproc))))])
|
||||
|
||||
(let ()
|
||||
(define (handle-dynamic-wind critical? in body out ctxt oldtypes)
|
||||
(let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?)
|
||||
(if critical?
|
||||
(Expr critical? 'value oldtypes)
|
||||
(values #f #f oldtypes #f #f))]
|
||||
[(ìn rin tin t-tin f-tin)
|
||||
(Expr/call in 'value tcritical? oldtypes)]
|
||||
[(body rbody tbody t-tbody f-tbody)
|
||||
(Expr/call body 'value tin oldtypes)] ; it's almost possible to use ctxt instead of 'value here
|
||||
[(out rout tout t-tout f-tout)
|
||||
(Expr/call out 'value tin oldtypes)]) ; use tin instead of tbody in case of error or jump.
|
||||
(let* ([n-types (pred-env-intersect/base tbody tout tin)]
|
||||
[t-types (and (eq? ctxt 'test)
|
||||
t-tbody
|
||||
(pred-env-rebase t-tbody tin n-types))]
|
||||
[f-types (and (eq? ctxt 'test)
|
||||
f-tbody
|
||||
(pred-env-rebase f-tbody tin n-types))])
|
||||
(values critical? in body out rbody n-types t-types f-types))))
|
||||
|
||||
(define-specialize/unrestricted 2 r6rs:dynamic-wind
|
||||
[(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
||||
(handle-dynamic-wind #f in body out ctxt oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,in ,body ,out)
|
||||
ret n-types t-types f-types))])
|
||||
(define-specialize/unrestricted 2 dynamic-wind
|
||||
[(in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
||||
(handle-dynamic-wind #f in body out ctxt oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,in ,body ,out)
|
||||
ret n-types t-types f-types))]
|
||||
[(critical? in body out) (let-values ([(critical? in body out ret n-types t-types f-types)
|
||||
(handle-dynamic-wind critical? in body out ctxt oldtypes)])
|
||||
(values `(call ,preinfo ,pr ,critical? ,in ,body ,out)
|
||||
ret n-types t-types f-types))])
|
||||
)
|
||||
|
||||
))
|
||||
|
||||
(with-output-language (Lsrc Expr)
|
||||
|
|
@ -884,7 +1030,24 @@ Notes:
|
|||
#f)])))
|
||||
|
||||
(define (fold-call/primref preinfo pr e* ctxt oldtypes)
|
||||
(fold-primref/next preinfo pr e* ctxt oldtypes))
|
||||
(fold-primref/unrestricted preinfo pr e* ctxt oldtypes))
|
||||
|
||||
(define (fold-primref/unrestricted preinfo pr e* ctxt oldtypes)
|
||||
(let* ([flags (primref-flags pr)]
|
||||
[prim-name (primref-name pr)]
|
||||
[handler (or (and (all-set? (prim-mask unsafe) flags)
|
||||
(all-set? (prim-mask cptypes3x) flags)
|
||||
($sgetprop prim-name 'cptypes3x #f))
|
||||
(and (all-set? (prim-mask cptypes2x) flags)
|
||||
($sgetprop prim-name 'cptypes2x #f)))])
|
||||
(if handler
|
||||
(call-with-values
|
||||
(lambda () (handler preinfo pr e* ctxt oldtypes fold-primref/next))
|
||||
(case-lambda
|
||||
[(ir2 ret2 types2 t-types2 f-types2)
|
||||
(values ir2 ret2 types2 t-types2 f-types2)]
|
||||
[else ($oops 'fold-primref "result of inline handler can't be #f")]))
|
||||
(fold-primref/next preinfo pr e* ctxt oldtypes))))
|
||||
|
||||
(define (fold-primref/next preinfo pr e* ctxt oldtypes)
|
||||
(let-values ([(t e* r* t* t-t* f-t*)
|
||||
|
|
@ -1340,7 +1503,7 @@ Notes:
|
|||
; currently all the flags use the same bit
|
||||
(let ([used (map (lambda (key) (and (getprop sym key #f)
|
||||
(begin (remprop sym 'cp02) #t)))
|
||||
'(cptypes2 cptypes3))])
|
||||
'(cptypes2 cptypes3 cptypes2x cptypes3x))])
|
||||
(when (andmap not used)
|
||||
($oops 'çptypes "no cptypes handler for ~s" sym))))))
|
||||
(oblist))
|
||||
|
|
|
|||
|
|
@ -337,12 +337,12 @@
|
|||
(vector-for-each [sig [(procedure vector vector ...) -> (ptr ...)]] [flags cp03])
|
||||
(error [sig [(maybe-who string ptr ...) -> (bottom)]] [flags abort-op])
|
||||
(assertion-violation [sig [(maybe-who string ptr ...) -> (bottom)]] [flags abort-op])
|
||||
(apply [sig [(procedure ptr ... list) -> (ptr ...)]] [flags cp02 ieee r5rs])
|
||||
(apply [sig [(procedure ptr ... list) -> (ptr ...)]] [flags cp02 cptypes2x ieee r5rs])
|
||||
(call-with-current-continuation [sig [(procedure) -> (ptr ...)]] [flags ieee r5rs])
|
||||
(call/cc [sig [(procedure) -> (ptr ...)]] [flags])
|
||||
(values [sig [(ptr ...) -> (ptr ...)]] [flags unrestricted discard cp02 ieee r5rs])
|
||||
(call-with-values [sig [(procedure procedure) -> (ptr ...)]] [flags cp02 ieee r5rs])
|
||||
((r6rs: dynamic-wind) [sig [(procedure procedure procedure) -> (ptr ...)]] [flags ieee r5rs]) ; restricted to 3 arguments
|
||||
(call-with-values [sig [(procedure procedure) -> (ptr ...)]] [flags cp02 cptypes2x ieee r5rs])
|
||||
((r6rs: dynamic-wind) [sig [(procedure procedure procedure) -> (ptr ...)]] [flags cptypes2x ieee r5rs]) ; restricted to 3 arguments
|
||||
)
|
||||
|
||||
(define-symbol-flags* ([libraries (rnrs) (rnrs bytevectors)] [flags keyword])
|
||||
|
|
@ -1270,7 +1270,7 @@
|
|||
(display-condition [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags])
|
||||
(display-statistics [sig [() (textual-output-port) -> (void)]] [flags true])
|
||||
(display-string [sig [(string) (string textual-output-port) -> (void)]] [flags true])
|
||||
(dynamic-wind [sig [(procedure procedure procedure) (ptr procedure procedure procedure) -> (ptr ...)]] [flags ieee r5rs])
|
||||
(dynamic-wind [sig [(procedure procedure procedure) (ptr procedure procedure procedure) -> (ptr ...)]] [flags cptypes2x ieee r5rs])
|
||||
(enable-interrupts [sig [() -> (uint)]] [flags true])
|
||||
(engine-block [sig [() -> (ptr)]] [flags])
|
||||
(engine-return [sig [(ptr ...) -> (bottom)]] [flags abort-op])
|
||||
|
|
@ -1785,7 +1785,7 @@
|
|||
($allocate-thread-parameter [feature pthreads] [flags single-valued alloc])
|
||||
($app [flags])
|
||||
($app/no-inline [flags])
|
||||
($apply [sig [(procedure exact-integer list) -> (ptr ...)]] [flags])
|
||||
($apply [sig [(procedure exact-integer list) -> (ptr ...)]] [flags cptypes2x])
|
||||
($assembly-output [flags single-valued])
|
||||
($as-time-goes-by [flags])
|
||||
($bignum-length [flags single-valued pure true])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user