cp0: move only known-single-valued out of single-value context
In safe compilation modes, avoid turning an error like (let ([x (values 1 2)]) x) or (car (list (values 1 2))) into a program that returns multiple values or (if (list (values 1 2)) 3 4) into a program that returns without an error. In addition, refrain from moving an expression from a non-tail position within a procedure to a tail position, unless the expression is not only single valued but also gauarnteed not to inspect the immediate continuation (e.g., using `call/cc` and comparing the result to a previously captured continuation). This constraint applies even in unsafe compilation modes, because the intent it to provide some guarantees about non-tail positions to complement existing guarantees of tail positions. original commit: 91e9631576e7b97137be856e985609320e327f32
This commit is contained in:
Matthew Flatt
parent
03a33fb4fc
commit
b78838a641
4
LOG
4
LOG
|
|
@ -1027,3 +1027,7 @@
|
|||
cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
|
||||
- added initialization of seginfo sorted and trigger_ephemerons fields.
|
||||
segment.c
|
||||
- adjust compiler, especially cp0, to avoid turning errors like `(let
|
||||
([x (values 1 2)]) x)` into programs that return multiple values
|
||||
cp0.ss, cpletrec.ss, cpnanopass, prims.ss, primdata.ss, priminfo.ss,
|
||||
primvars.ss, cmacros.ss, syntax.ss, cp0.ms, record.ms
|
||||
|
|
|
|||
942
mats/cp0.ms
942
mats/cp0.ms
File diff suppressed because it is too large
Load Diff
|
|
@ -8853,7 +8853,7 @@
|
|||
(make-foo 3))))
|
||||
`(let ([ctr 0])
|
||||
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
|
||||
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
|
||||
(#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type))
|
||||
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr)))))
|
||||
(equivalent-expansion?
|
||||
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||||
|
|
@ -8872,7 +8872,7 @@
|
|||
(make-foo 3))))
|
||||
`(let ([ctr 0])
|
||||
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
|
||||
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
|
||||
(#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type))
|
||||
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr)))))
|
||||
(error? ; invalid uid
|
||||
(let ()
|
||||
|
|
|
|||
13
s/cmacros.ss
13
s/cmacros.ss
|
|
@ -1562,18 +1562,19 @@
|
|||
(ieee #b00000000000000000010000)
|
||||
(proc #b00000000000000000100000)
|
||||
(discard #b00000000000000001000000)
|
||||
(unrestricted #b00000000000000010000000)
|
||||
(true #b00000000000000100000000)
|
||||
(mifoldable #b00000000000001000000000)
|
||||
(single-valued #b00000000000000010000000)
|
||||
(true (or #b00000000000000100000000 single-valued))
|
||||
(mifoldable (or #b00000000000001000000000 single-valued))
|
||||
(cp02 #b00000000000010000000000)
|
||||
(cp03 #b00000000000100000000000)
|
||||
(system-keyword #b00000000001000000000000)
|
||||
(r6rs #b00000000010000000000000)
|
||||
(pure (or #b00000000100000000000000 discard))
|
||||
(pure (or #b00000000100000000000000 discard single-valued))
|
||||
(library-uid #b00000001000000000000000)
|
||||
(boolean-valued #b00000010000000000000000)
|
||||
(boolean-valued (or #b00000010000000000000000 single-valued))
|
||||
(abort-op #b00000100000000000000000)
|
||||
(unsafe #b00001000000000000000000)
|
||||
(unrestricted #b00010000000000000000000)
|
||||
(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
|
||||
|
|
@ -1589,6 +1590,8 @@
|
|||
(simple #b0000100000)
|
||||
(boolean-valued-known #b0001000000)
|
||||
(boolean-valued #b0010000000)
|
||||
(single-valued-known #b0100000000)
|
||||
(single-valued #b1000000000)
|
||||
)
|
||||
|
||||
(define-syntax define-flag-field
|
||||
|
|
|
|||
404
s/cp0.ss
404
s/cp0.ss
|
|
@ -230,6 +230,26 @@
|
|||
|
||||
;;; contexts
|
||||
|
||||
;; 'value - result used, context checks for single-value result,
|
||||
;; not in tail position within an enclosing function
|
||||
;; 'test - result used as boolean, context checks for single-value result,
|
||||
;; not in tail position within an enclosing function
|
||||
;; 'tail - result used, multiple values ok, in tail position
|
||||
;; within an enclosing function
|
||||
;; 'effect - result not used, multiple values ok, not in tail
|
||||
;; position
|
||||
;; 'ignored - result not used, must produce a single value,
|
||||
;; not in tail position
|
||||
|
||||
;; Beware that "ctxt" sometimes actually refers to an app context,
|
||||
;; not one of the above contexts.
|
||||
|
||||
(define (context-imposes-single-value? ctxt)
|
||||
(or (eq? ctxt 'value) (eq? ctxt 'test)))
|
||||
|
||||
(define (unused-value-context? ctxt)
|
||||
(or (eq? ctxt 'effect) (eq? ctxt 'ignored)))
|
||||
|
||||
;; app context:
|
||||
;; opnds are the operands at the call site
|
||||
;; ctxt is the outer context
|
||||
|
|
@ -456,7 +476,7 @@
|
|||
; further, require each RHS to be pure unless the body is pure, since it's
|
||||
; unsound to split apart two things that can observe a side effect or two
|
||||
; allocation operations that can be separated by a continuation grab.
|
||||
[(if (ivory? body) (andmap simple/profile? e*) (andmap ivory? e*))
|
||||
[(if (ivory? body) (andmap simple/profile1? e*) (andmap ivory1? e*))
|
||||
; assocate each lhs with cooked operand for corresponding rhs. make-record-constructor-descriptor,
|
||||
; at least, counts on this to allow protocols to be inlined.
|
||||
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
|
||||
|
|
@ -496,7 +516,7 @@
|
|||
; pure OR body to be pure, since we can't separate non-pure
|
||||
; RHS and body expressions
|
||||
[(letrec ([,x* ,e*] ...) ,body)
|
||||
(guard (or (ivory? body) (andmap ivory? e*)))
|
||||
(guard (or (ivory? body) (andmap ivory1? e*)))
|
||||
; assocate each lhs with cooked operand for corresponding rhs. see note above.
|
||||
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
|
||||
(values (make-lifted #f x* e*) body)]
|
||||
|
|
@ -510,7 +530,7 @@
|
|||
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
|
||||
(values (make-lifted #t x* e*) (build-ref x))))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
(guard (or (ivory? body) (andmap ivory? e*)))
|
||||
(guard (or (ivory? body) (andmap ivory1? e*)))
|
||||
; assocate each lhs with cooked operand for corresponding rhs. see note above.
|
||||
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
|
||||
(values (make-lifted #t x* e*) body)]
|
||||
|
|
@ -597,9 +617,9 @@
|
|||
(if (null? todo)
|
||||
e
|
||||
(f (cdr todo)
|
||||
(make-seq ctxt
|
||||
(make-1seq ctxt
|
||||
(let ((opnd (car todo)))
|
||||
(cp0 (operand-exp opnd) 'effect (operand-env opnd)
|
||||
(cp0 (operand-exp opnd) 'ignored (operand-env opnd)
|
||||
sc (operand-wd opnd) (operand-name opnd) (operand-moi opnd)))
|
||||
e)))))
|
||||
(let ((opnd (car unused)))
|
||||
|
|
@ -614,7 +634,7 @@
|
|||
; we add in the entire score here
|
||||
; if singly-referenced integration attempt in copy2 succeeded, but
|
||||
; value isn't simple, we also pay the whole price
|
||||
(make-seq ctxt e (f (cdr unused) (fx+ n (operand-score opnd)) todo)))
|
||||
(make-1seq ctxt e (f (cdr unused) (fx+ n (operand-score opnd)) todo)))
|
||||
(if (operand-singly-referenced-score opnd)
|
||||
; singly-referenced integration attempt in ref-case of cp0 succeeded
|
||||
(f (cdr unused) (fx+ (operand-singly-referenced-score opnd) n) todo)
|
||||
|
|
@ -714,16 +734,35 @@
|
|||
(lambda (ctxt e1 e2)
|
||||
(if (simple? e1)
|
||||
e2
|
||||
(if (and (eq? ctxt 'effect) (simple? e2))
|
||||
e1
|
||||
(let ([e1 (nanopass-case (Lsrc Expr) e1
|
||||
[(seq ,e11 ,e12)
|
||||
(guard (simple? e12))
|
||||
e11]
|
||||
[else e1])])
|
||||
(nanopass-case (Lsrc Expr) e2
|
||||
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
|
||||
[else `(seq ,e1 ,e2)]))))))
|
||||
(cond
|
||||
[(and (eq? ctxt 'effect) (simple? e2))
|
||||
e1]
|
||||
[(and (eq? ctxt 'ignored) (simple1? e2)
|
||||
;; don't move e1 into a single-value
|
||||
;; position unless that's ok
|
||||
(single-valued? e1))
|
||||
e1]
|
||||
[else
|
||||
(let ([e1 (nanopass-case (Lsrc Expr) e1
|
||||
[(seq ,e11 ,e12)
|
||||
(guard (simple? e12))
|
||||
e11]
|
||||
[else e1])])
|
||||
(nanopass-case (Lsrc Expr) e2
|
||||
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
|
||||
[else `(seq ,e1 ,e2)]))]))))
|
||||
|
||||
(define make-1seq
|
||||
;; like `make-seq`, but preserves the requirement that `e1`
|
||||
;; produces a single value when compiling in safe mode
|
||||
(lambda (ctxt e1 e2)
|
||||
(make-seq ctxt (safe-single-value e1) e2)))
|
||||
|
||||
(define (safe-single-value e1)
|
||||
(if (or (fx= (optimize-level) 3)
|
||||
(single-valued? e1))
|
||||
e1
|
||||
(build-primcall 3 '$value (list e1))))
|
||||
|
||||
(define make-seq* ; requires at least one operand
|
||||
(lambda (ctxt e*)
|
||||
|
|
@ -731,10 +770,16 @@
|
|||
(car e*)
|
||||
(make-seq ctxt (car e*) (make-seq* ctxt (cdr e*))))))
|
||||
|
||||
(define make-1seq* ; requires at least one operand
|
||||
(lambda (ctxt e*)
|
||||
(if (null? (cdr e*))
|
||||
(safe-single-value (car e*))
|
||||
(make-1seq ctxt (car e*) (make-1seq* ctxt (cdr e*))))))
|
||||
|
||||
(define make-if
|
||||
(lambda (ctxt sc e1 e2 e3)
|
||||
(cond
|
||||
[(record-equal? e2 e3 ctxt) (make-seq ctxt e1 e2)]
|
||||
[(record-equal? e2 e3 ctxt) (make-1seq ctxt e1 e2)]
|
||||
[(and (cp0-constant? (lambda (x) (eq? x #f)) e3)
|
||||
(record-equal? e1 e2 (if (eq? ctxt 'test) 'test 'value))
|
||||
(simple? e1))
|
||||
|
|
@ -745,8 +790,8 @@
|
|||
(let ([d12 (cp0-datum re12)] [d13 (cp0-datum re13)])
|
||||
(non-result-exp e1
|
||||
(cond
|
||||
[(and d12 d13) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e2)]
|
||||
[(not (or d12 d13)) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e3)]
|
||||
[(and d12 d13) (make-1seq ctxt (make-if 'ignored sc e11 e12 e13) e2)]
|
||||
[(not (or d12 d13)) (make-1seq ctxt (make-if 'ignored sc e11 e12 e13) e3)]
|
||||
[else (let-values ([(e2 e3) (if d12 (values e2 e3) (values e3 e2))])
|
||||
(make-if ctxt sc e11 (non-result-exp e12 e2) (non-result-exp e13 e3)))])))
|
||||
#f)]
|
||||
|
|
@ -755,6 +800,15 @@
|
|||
(bump sc 1)
|
||||
`(if ,e1 ,e2 ,e3)])))
|
||||
|
||||
(define make-nontail
|
||||
(lambda (ctxt e)
|
||||
(if (context-case ctxt
|
||||
[(tail) (single-valued-nontail? e)]
|
||||
[(ignored) (single-valued? e)]
|
||||
[else #t])
|
||||
e
|
||||
(build-primcall 3 '$value (list e)))))
|
||||
|
||||
(define result-exp
|
||||
(lambda (e)
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
|
|
@ -879,7 +933,7 @@
|
|||
((ids->do-clause '()) clause)
|
||||
#t))))
|
||||
|
||||
(module (pure? ivory? simple? simple/profile? boolean-valued?)
|
||||
(module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? single-valued? single-valued-nontail?)
|
||||
(define-syntax make-$memoize
|
||||
(syntax-rules ()
|
||||
[(_ flag-known flag)
|
||||
|
|
@ -927,7 +981,7 @@
|
|||
(memoize (and (or (not maybe-e) (pure? maybe-e)) (andmap pure? e*))))]
|
||||
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
|
||||
(guard (fx= interface (length e*)))
|
||||
(memoize (and (or (not maybe-e) (pure? maybe-e)) (pure? body) (andmap pure? e*)))]
|
||||
(memoize (and (or (not maybe-e) (pure? maybe-e)) (pure? body) (andmap pure1? e*)))]
|
||||
[else #f])))
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(seq ,e1 ,e2) (pure-call? e1 e2)]
|
||||
|
|
@ -935,7 +989,7 @@
|
|||
[(quote ,d) #t]
|
||||
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (pure? e1) (pure? e2) (pure? e3)))]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (pure1? e1) (pure? e2) (pure? e3)))]
|
||||
[(seq ,e1 ,e2) (memoize (and (pure? e1) (pure? e2)))]
|
||||
[(record-ref ,rtd ,type ,index ,e) #f]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
|
||||
|
|
@ -944,21 +998,26 @@
|
|||
(and (not (fld-mutable? fld))
|
||||
(eq? (filter-foreign-type (fld-type fld)) 'scheme-object)))
|
||||
(rtd-flds rtd))
|
||||
(memoize (and (pure? rtd-expr) (andmap pure? e*))))]
|
||||
(memoize (and (pure1? rtd-expr) (andmap pure1? e*))))]
|
||||
[(set! ,maybe-src ,x ,e) #f]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
|
||||
[(record-type ,rtd ,e) (memoize (pure? e))]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure1? e))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))]
|
||||
[(record-type ,rtd ,e) (memoize (pure1? e))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure1? e*) (pure? e)))]
|
||||
[(profile ,src) #t]
|
||||
[(cte-optimization-loc ,box ,e) (memoize (pure? e))]
|
||||
[(moi) #t]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure1? e))]
|
||||
[(pariah) #t]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define pure1?
|
||||
(lambda (e)
|
||||
(and (pure? e)
|
||||
(or (fx= (optimize-level) 3) (single-valued? e)))))
|
||||
|
||||
(define-who ivory? ; 99.44% pure
|
||||
; does not cause or observe any effects, capture or invoke a continuation,
|
||||
; or allocate mutable data structures. might contain profile forms, so
|
||||
|
|
@ -982,10 +1041,10 @@
|
|||
(all-set? (prim-mask pure) flags)
|
||||
(all-set? (prim-mask (or pure unrestricted)) flags)))
|
||||
(arity-okay? (primref-arity e) (length e*))
|
||||
(memoize (and (or (not maybe-e) (ivory? maybe-e)) (andmap ivory? e*))))]
|
||||
(memoize (and (or (not maybe-e) (ivory? maybe-e)) (andmap ivory1? e*))))]
|
||||
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
|
||||
(guard (fx= interface (length e*)))
|
||||
(memoize (and (or (not maybe-e) (ivory? maybe-e)) (ivory? body) (andmap ivory? e*)))]
|
||||
(memoize (and (or (not maybe-e) (ivory? maybe-e)) (ivory? body) (andmap ivory1? e*)))]
|
||||
[else #f])))
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(seq ,e1 ,e2) (ivory-call? e1 e2)]
|
||||
|
|
@ -993,31 +1052,36 @@
|
|||
[(quote ,d) #t]
|
||||
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (ivory? e1) (ivory? e2) (ivory? e3)))]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (ivory1? e1) (ivory? e2) (ivory? e3)))]
|
||||
[(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))]
|
||||
[(record-ref ,rtd ,type ,index ,e)
|
||||
; here ivory? differs from pure?
|
||||
(and (not (fld-mutable? (list-ref (rtd-flds rtd) index)))
|
||||
(memoize (ivory? e)))]
|
||||
(memoize (ivory1? e)))]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
|
||||
[(record ,rtd ,rtd-expr ,e* ...)
|
||||
; here ivory? differs from pure?
|
||||
(and (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds rtd))
|
||||
(memoize (and (ivory? rtd-expr) (andmap ivory? e*))))]
|
||||
(memoize (and (ivory1? rtd-expr) (andmap ivory1? e*))))]
|
||||
[(set! ,maybe-src ,x ,e) #f]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
|
||||
[(record-type ,rtd ,e) (memoize (ivory? e))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory1? e))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))]
|
||||
[(record-type ,rtd ,e) (memoize (ivory1? e))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory1? e*) (ivory? e)))]
|
||||
[(profile ,src) #t]
|
||||
[(cte-optimization-loc ,box ,e) (memoize (ivory? e))]
|
||||
[(moi) #t]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))]
|
||||
[(pariah) #t]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define ivory1?
|
||||
(lambda (e)
|
||||
(and (ivory? e)
|
||||
(or (fx= (optimize-level) 3) (single-valued? e)))))
|
||||
|
||||
(define-who simple?
|
||||
(lambda (e)
|
||||
(with-memoize (simple-known simple) e
|
||||
|
|
@ -1035,33 +1099,39 @@
|
|||
(all-set? (prim-mask discard) flags)
|
||||
(all-set? (prim-mask (or discard unrestricted)) flags))
|
||||
(arity-okay? (primref-arity pr) (length e*))
|
||||
(memoize (andmap simple? e*))))]
|
||||
(memoize (andmap simple1? e*))))]
|
||||
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
|
||||
(guard (fx= interface (length e*)))
|
||||
(memoize (and (simple? body) (andmap simple? e*)))]
|
||||
(memoize (and (simple? body) (andmap simple1? e*)))]
|
||||
[else #f])]
|
||||
[(ref ,maybe-src ,x) #t]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (simple? e1) (simple? e2) (simple? e3)))]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (simple1? e1) (simple? e2) (simple? e3)))]
|
||||
[(seq ,e1 ,e2) (memoize (and (simple? e1) (simple? e2)))]
|
||||
[(set! ,maybe-src ,x ,e) #f]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap simple? e*) (simple? e)))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap simple1? e*) (simple? e)))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple1? e*) (simple? body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple1? e*) (simple? body)))]
|
||||
[,pr #t]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))]
|
||||
[(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple1? e))]
|
||||
[(record-ref ,rtd ,type ,index ,e) (memoize (simple1? e))]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
|
||||
[(record-type ,rtd ,e) (memoize (simple? e))]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))]
|
||||
[(record-type ,rtd ,e) (memoize (simple1? e))]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple1? rtd-expr) (andmap simple1? e*)))]
|
||||
[(pariah) #f]
|
||||
[(profile ,src) #f]
|
||||
[(cte-optimization-loc ,box ,e) (memoize (simple? e))]
|
||||
[(moi) #t]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define simple1?
|
||||
(lambda (e)
|
||||
(and (simple? e)
|
||||
(or (fx= (optimize-level) 3)
|
||||
(single-valued? e)))))
|
||||
|
||||
(define-who simple/profile?
|
||||
; like simple? but allows profile forms. used for lifting bindings.
|
||||
(lambda (e)
|
||||
|
|
@ -1080,33 +1150,38 @@
|
|||
(all-set? (prim-mask discard) flags)
|
||||
(all-set? (prim-mask (or discard unrestricted)) flags))
|
||||
(arity-okay? (primref-arity pr) (length e*))
|
||||
(memoize (andmap simple/profile? e*))))]
|
||||
(memoize (andmap simple/profile1? e*))))]
|
||||
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
|
||||
(guard (fx= interface (length e*)))
|
||||
(memoize (and (simple/profile? body) (andmap simple/profile? e*)))]
|
||||
(memoize (and (simple/profile? body) (andmap simple/profile1? e*)))]
|
||||
[else #f])]
|
||||
[(ref ,maybe-src ,x) #t]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (simple/profile? e1) (simple/profile? e2) (simple/profile? e3)))]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (simple/profile1? e1) (simple/profile? e2) (simple/profile? e3)))]
|
||||
[(seq ,e1 ,e2) (memoize (and (simple/profile? e1) (simple/profile? e2)))]
|
||||
[(set! ,maybe-src ,x ,e) #f]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap simple/profile? e*) (simple/profile? e)))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))]
|
||||
[(immutable-list (,e* ...) ,e) (memoize (and (andmap simple/profile1? e*) (simple/profile? e)))]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile1? e*) (simple/profile? body)))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile1? e*) (simple/profile? body)))]
|
||||
[,pr #t]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))]
|
||||
[(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile1? e))]
|
||||
[(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile1? e))]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
|
||||
[(record-type ,rtd ,e) (memoize (simple/profile? e))]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))]
|
||||
[(record-type ,rtd ,e) (memoize (simple/profile1? e))]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile1? rtd-expr) (andmap simple/profile1? e*)))]
|
||||
[(pariah) #t]
|
||||
[(profile ,src) #t]
|
||||
[(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))]
|
||||
[(moi) #t]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define simple/profile1?
|
||||
(lambda (e)
|
||||
(and (simple/profile? e)
|
||||
(or (fx= (optimize-level) 3) (single-valued? e)))))
|
||||
|
||||
(define-who boolean-valued?
|
||||
(lambda (e)
|
||||
(with-memoize (boolean-valued-known boolean-valued) e
|
||||
|
|
@ -1140,7 +1215,52 @@
|
|||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f]
|
||||
[(pariah) #f]
|
||||
[else ($oops who "unrecognized record ~s" e)])))))
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define-who single-valued?
|
||||
(lambda (e)
|
||||
(with-memoize (single-valued-known single-valued) e
|
||||
; known to produce a single value
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[(quote ,d) #t]
|
||||
[(call ,preinfo ,e ,e* ...)
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
[,pr (all-set? (prim-mask single-valued) (primref-flags pr))]
|
||||
[(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
|
||||
(guard (fx= interface (length e*)))
|
||||
(memoize (single-valued? body))]
|
||||
[else #f])]
|
||||
[(ref ,maybe-src ,x) #t]
|
||||
[(case-lambda ,preinfo ,cl* ...) #t]
|
||||
[(if ,e1 ,e2 ,e3) (memoize (and (single-valued? e2) (single-valued? e3)))]
|
||||
[(seq ,e1 ,e2) (memoize (single-valued? e2))]
|
||||
[(set! ,maybe-src ,x ,e) #t]
|
||||
[(immutable-list (,e* ...) ,e) #t]
|
||||
[(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued? body))]
|
||||
[(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued? body))]
|
||||
[,pr #t]
|
||||
[(record-cd ,rcd ,rtd-expr ,e) #t]
|
||||
[(record-ref ,rtd ,type ,index ,e) #t]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
|
||||
[(record-type ,rtd ,e) #t]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) #t]
|
||||
[(pariah) #t]
|
||||
[(profile ,src) #t]
|
||||
[(cte-optimization-loc ,box ,e) (memoize (single-valued? e))]
|
||||
[(moi) #t]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
|
||||
[else ($oops who "unrecognized record ~s" e)]))))
|
||||
|
||||
(define-who single-valued-nontail?
|
||||
(lambda (e)
|
||||
;; Single-valued and does not observe or affect the
|
||||
;; immediate continuation frame (so removing (an enclosing
|
||||
;; frame would be ok). This currently can be implemented as
|
||||
;; `single-valued?`, because `single-valued?` does not look
|
||||
;; into continuation-observing calls like `(call/cc (lambda
|
||||
;; (k) <body>))` to detect that `<body>` is single valued.
|
||||
(single-valued? e))))
|
||||
|
||||
(define find-call-lambda-clause
|
||||
(lambda (exp opnds)
|
||||
|
|
@ -1274,7 +1394,7 @@
|
|||
[else #f]))
|
||||
; (let ((x e)) x) => e
|
||||
; x is clearly not assigned, even if flags are polluted and say it is
|
||||
(car rhs*)]
|
||||
(make-nontail (app-ctxt ctxt) (car rhs*))]
|
||||
; we drop the RHS of a let binding into the let body when the body expression is a call
|
||||
; and we can do so without violating evaluation order of bindings wrt the let body:
|
||||
; * for pure, singly referenced bindings, we drop them to the variable reference site
|
||||
|
|
@ -1436,7 +1556,7 @@
|
|||
(when change? (loop pending-ids pending-opnds '() '() #f))
|
||||
(let ([id (car ids)] [opnd (car opnds)])
|
||||
(if (or (prelex-referenced id)
|
||||
(not (simple? (operand-exp opnd))))
|
||||
(not (simple1? (operand-exp opnd))))
|
||||
(begin
|
||||
(value-visit-operand! opnd)
|
||||
(loop (cdr ids) (cdr opnds) pending-ids pending-opnds
|
||||
|
|
@ -1451,7 +1571,7 @@
|
|||
(bump sc n)
|
||||
(if (or (null? ids)
|
||||
; don't allow conservative referenced flags prevent constant folding
|
||||
(and (cp0-constant? body) (andmap simple? vals)))
|
||||
(and (cp0-constant? body) (andmap simple1? vals)))
|
||||
body
|
||||
(if seq?
|
||||
`(letrec* ([,(reverse ids) ,(reverse vals)] ...) ,body)
|
||||
|
|
@ -1463,7 +1583,7 @@
|
|||
; scoring bug: we don't count size of bindings when we
|
||||
; drop the rest of the RHS
|
||||
(define (f ids vals seq?)
|
||||
(if (or (prelex-referenced id) (not (simple? val)))
|
||||
(if (or (prelex-referenced id) (not (simple1? val)))
|
||||
(loop (cdr old-ids) (cdr opnds) (cons id ids)
|
||||
(cons val vals) (+ n (operand-score opnd)) seq?)
|
||||
(let ([n (+ (or (operand-singly-referenced-score opnd) 0) n)])
|
||||
|
|
@ -1609,7 +1729,7 @@
|
|||
[else (residualize-ref maybe-src id sc)])]
|
||||
[,pr
|
||||
(context-case ctxt
|
||||
[(value)
|
||||
[(value tail)
|
||||
(if (all-set? (prim-mask (or primitive proc)) (primref-flags pr))
|
||||
rhs
|
||||
(residualize-ref maybe-src id sc))]
|
||||
|
|
@ -1625,11 +1745,14 @@
|
|||
(let ([opnds (app-opnds ctxt)] [outer-ctxt (app-ctxt ctxt)])
|
||||
(let ([flags (primref-flags pr)])
|
||||
(cond
|
||||
[(and (eq? outer-ctxt 'effect)
|
||||
[(and (unused-value-context? outer-ctxt)
|
||||
(if (all-set? (prim-mask unsafe) flags)
|
||||
(all-set? (prim-mask discard) flags)
|
||||
(and (all-set? (prim-mask (or unrestricted discard)) flags)
|
||||
(arity-okay? (primref-arity pr) (length opnds)))))
|
||||
(arity-okay? (primref-arity pr) (length opnds))))
|
||||
(or (not (eq? outer-ctxt 'ignored))
|
||||
(fx= (optimize-level) 3)
|
||||
(all-set? (prim-mask single-valued) flags)))
|
||||
(residualize-seq '() opnds ctxt)
|
||||
void-rec]
|
||||
[(and (eq? outer-ctxt 'test)
|
||||
|
|
@ -1642,7 +1765,7 @@
|
|||
true-rec]
|
||||
[(and (eq? outer-ctxt 'test)
|
||||
(all-set? (prim-mask true) flags))
|
||||
(make-seq outer-ctxt
|
||||
(make-1seq outer-ctxt
|
||||
(fold-primref2 pr (primref-name pr) opnds flags ctxt sc wd name moi)
|
||||
true-rec)]
|
||||
[else (fold-primref2 pr (primref-name pr) opnds flags ctxt sc wd name moi)])))))
|
||||
|
|
@ -1691,7 +1814,7 @@
|
|||
(define record-equal?
|
||||
; not very ambitious
|
||||
(lambda (e1 e2 ctxt)
|
||||
(if (eq? ctxt 'effect)
|
||||
(if (unused-value-context? ctxt)
|
||||
(and (simple? e1) (simple? e2))
|
||||
(nanopass-case (Lsrc Expr) e1
|
||||
[(ref ,maybe-src1 ,x1)
|
||||
|
|
@ -2052,24 +2175,11 @@
|
|||
[(and (app-used ctxt1)
|
||||
(let ([e (result-exp *p-val)])
|
||||
(nanopass-case (Lsrc Expr) e
|
||||
; in dire need of matching more than one pattern
|
||||
[(quote ,d) (list e)]
|
||||
[(ref ,maybe-src ,x) (list e)]
|
||||
[(set! ,maybe-src ,x0 ,e0) (list e)]
|
||||
[(case-lambda ,preinfo ,cl* ...) (list e)]
|
||||
[,pr (list e)]
|
||||
[(foreign (,conv* ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
|
||||
[(fcallable (,conv* ...) ,e0 (,arg-type* ...) ,result-type) (list e)]
|
||||
[(record-type ,rtd0 ,e0) (list e)]
|
||||
[(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)]
|
||||
[(immutable-list (,e0* ...) ,e0) (list e)]
|
||||
[(record-ref ,rtd ,type ,index ,e0) (list e)]
|
||||
[(record-set! ,rtd ,type ,index ,e1 ,e2) (list e)]
|
||||
[(record ,rtd ,rtd-expr ,e* ...) (list e)]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (eq? (primref-name pr) 'values))
|
||||
e*]
|
||||
[else #f]))) =>
|
||||
[else (and (single-valued? e)
|
||||
(list e))]))) =>
|
||||
(lambda (args)
|
||||
; (with-values (values arg ...) c-temp) => (c-temp arg ...)
|
||||
(letify (make-preinfo-lambda) ids ctxt
|
||||
|
|
@ -2117,11 +2227,18 @@
|
|||
[args #f])
|
||||
|
||||
(define-inline 2 (cons* list* values append append!)
|
||||
[(x) (let ((xval (value-visit-operand! x)))
|
||||
[(x) (begin
|
||||
(residualize-seq (list x) '() ctxt)
|
||||
xval)]
|
||||
(make-nontail (app-ctxt ctxt) (value-visit-operand! x)))]
|
||||
[args #f])
|
||||
|
||||
(define-inline 2 $value
|
||||
[(x) (let ([v (value-visit-operand! x)])
|
||||
(and (single-valued? v)
|
||||
(begin
|
||||
(residualize-seq (list x) '() ctxt)
|
||||
v)))])
|
||||
|
||||
(define-inline 2 vector
|
||||
[() (begin
|
||||
(residualize-seq '() '() ctxt)
|
||||
|
|
@ -3619,7 +3736,7 @@
|
|||
(cons `(call ,preinfo (ref #f ,p)
|
||||
,(map (lambda (t*) (build-ref (car t*))) t**) ...)
|
||||
(g (map cdr t**))))))])
|
||||
(if (and map? (not (eq? (app-ctxt ctxt) 'effect)))
|
||||
(if (and map? (not (unused-value-context? (app-ctxt ctxt))))
|
||||
(if (null? results)
|
||||
null-rec
|
||||
(build-primcall lvl 'list results))
|
||||
|
|
@ -3656,7 +3773,7 @@
|
|||
; could treat map in effect context as for-each, but don't because (our)
|
||||
; map is guaranteed (even at optimization level 3) not to get sick if an
|
||||
; input list is mutated, while for-each is not.
|
||||
[(and (eq? (app-ctxt ctxt) 'effect)
|
||||
[(and (unused-value-context? (app-ctxt ctxt))
|
||||
(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p))
|
||||
[,pr (let ([flags (primref-flags pr)])
|
||||
(and (if (all-set? (prim-mask unsafe) flags)
|
||||
|
|
@ -3705,8 +3822,8 @@
|
|||
(list (build-ref x))))
|
||||
ls*) ...)
|
||||
ropnd*))])
|
||||
(if (eq? ctxt 'effect)
|
||||
(make-seq* ctxt opnd*)
|
||||
(if (unused-value-context? ctxt)
|
||||
(make-1seq* ctxt opnd*)
|
||||
(build-primcall 3 'list opnd*)))
|
||||
(let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)])
|
||||
(build-let tls*
|
||||
|
|
@ -3836,7 +3953,7 @@
|
|||
(define-inline 3 vector-map
|
||||
[(?p ?v . ?v*)
|
||||
(cond
|
||||
[(eq? (app-ctxt ctxt) 'effect)
|
||||
[(unused-value-context? (app-ctxt ctxt))
|
||||
; treat vector-map in effect context as vector-for-each
|
||||
(cp0 (lookup-primref 3 'vector-for-each) ctxt empty-env sc wd name moi)]
|
||||
[(ormap (lambda (?v)
|
||||
|
|
@ -4173,19 +4290,19 @@
|
|||
(and (not (null? e*))
|
||||
(begin
|
||||
(residualize-seq '() (list ?x) ctxt)
|
||||
(car e*)))]
|
||||
(make-nontail (app-ctxt ctxt) (car e*))))]
|
||||
[(call ,preinfo ,pr ,e1 ,e2)
|
||||
(guard (eq? (primref-name pr) 'cons))
|
||||
(residualize-seq (list ?x) '() ctxt)
|
||||
(non-result-exp (operand-value ?x)
|
||||
(make-seq (app-ctxt ctxt) e2 e1))]
|
||||
(make-1seq (app-ctxt ctxt) e2 (make-nontail (app-ctxt ctxt) e1)))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (memq (primref-name pr) '(list list* cons*)) (not (null? e*)))
|
||||
(residualize-seq (list ?x) '() ctxt)
|
||||
(non-result-exp (operand-value ?x)
|
||||
(fold-right
|
||||
(lambda (e1 e2) (make-seq (app-ctxt ctxt) e1 e2))
|
||||
(car e*)
|
||||
(lambda (e1 e2) (make-1seq (app-ctxt ctxt) e1 e2))
|
||||
(make-nontail (app-ctxt ctxt) (car e*))
|
||||
(cdr e*)))]
|
||||
[else #f])])
|
||||
|
||||
|
|
@ -4203,18 +4320,18 @@
|
|||
(guard (eq? (primref-name pr) 'cons))
|
||||
(residualize-seq (list ?x) '() ctxt)
|
||||
(non-result-exp (operand-value ?x)
|
||||
(make-seq (app-ctxt ctxt) e1 e2))]
|
||||
(make-1seq (app-ctxt ctxt) e1 (make-nontail (app-ctxt ctxt) e2)))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (eq? (primref-name pr) 'list) (not (null? e*)))
|
||||
(residualize-seq (list ?x) '() ctxt)
|
||||
(non-result-exp (operand-value ?x)
|
||||
(make-seq (app-ctxt ctxt) (car e*)
|
||||
(make-1seq (app-ctxt ctxt) (car e*)
|
||||
(build-call (app-preinfo ctxt) pr (cdr e*))))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(guard (memq (primref-name pr) '(list* cons*)) (>= (length e*) 2))
|
||||
(residualize-seq (list ?x) '() ctxt)
|
||||
(non-result-exp (operand-value ?x)
|
||||
(make-seq (app-ctxt ctxt) (car e*)
|
||||
(make-1seq (app-ctxt ctxt) (car e*)
|
||||
(build-call (app-preinfo ctxt) pr (cdr e*))))]
|
||||
[else #f])])
|
||||
|
||||
|
|
@ -4228,12 +4345,12 @@
|
|||
(let ([ed (car e*)])
|
||||
(and (edok? (result-exp ed)) (f (cdr e*) (fx- d 1) ed)))
|
||||
(let ([e (f (cdr e*) (fx- d 1) ed)])
|
||||
(and e (make-seq (app-ctxt ctxt) (car e*) e))))))])
|
||||
(and e (edok? (result-exp (car e*))) (make-1seq (app-ctxt ctxt) (car e*) e))))))])
|
||||
(and e (begin
|
||||
(residualize-seq (list ?x ?i) '() ctxt)
|
||||
(non-result-exp (operand-value ?i) ; do first ...
|
||||
(non-result-exp (operand-value ?x) ; ... so we keep ?x related side effects together
|
||||
e)))))))
|
||||
(make-nontail (app-ctxt ctxt) e))))))))
|
||||
|
||||
(define tryref
|
||||
(lambda (ctxt ?x ?i seqprim maybe-pred)
|
||||
|
|
@ -4419,7 +4536,7 @@
|
|||
[(quote ,d) ir]
|
||||
[(ref ,maybe-src ,x)
|
||||
(context-case ctxt
|
||||
[(effect) void-rec]
|
||||
[(effect ignored) void-rec]
|
||||
[else
|
||||
(let ((new-id (lookup x env)))
|
||||
(when (eq? new-id x)
|
||||
|
|
@ -4486,7 +4603,7 @@
|
|||
[(if ,[cp0 : e1 'test env sc wd #f moi -> e1] ,e2 ,e3)
|
||||
(nanopass-case (Lsrc Expr) (result-exp e1)
|
||||
[(quote ,d)
|
||||
(make-seq ctxt e1 (cp0 (if d e2 e3) ctxt env sc wd name moi))]
|
||||
(make-1seq ctxt e1 (cp0 (if d e2 e3) ctxt env sc wd name moi))]
|
||||
[else
|
||||
(let ((noappctxt (if (app? ctxt) 'value ctxt)))
|
||||
(let ([e2 (cp0 e2 noappctxt env sc wd name moi)]
|
||||
|
|
@ -4500,7 +4617,13 @@
|
|||
(let ((e (cp0 e 'value env sc wd (prelex-name x) moi)))
|
||||
(set-prelex-assigned! new-id #t)
|
||||
`(set! ,maybe-src ,new-id ,e)))
|
||||
(make-seq ctxt (cp0 e 'effect env sc wd (prelex-name x) moi) void-rec)))]
|
||||
(make-1seq ctxt (cp0 e 'ignored env sc wd (prelex-name x) moi) void-rec)))]
|
||||
[(call ,preinfo ,pr (seq ,e1 ,e2))
|
||||
(guard (eq? (primref-name pr) '$value))
|
||||
;; This simplication probably doesn't enable optimizations, but
|
||||
;; it cleans up and normalizes output, which is at least helpful
|
||||
;; for testing
|
||||
(cp0 `(seq ,e1 (call ,preinfo ,pr ,e2)) ctxt env sc wd name moi)]
|
||||
[(call ,preinfo ,e ,e* ...)
|
||||
(let ()
|
||||
(define lift-let
|
||||
|
|
@ -4545,7 +4668,7 @@
|
|||
(let ([x ($symbol-name name)])
|
||||
(if (pair? x) (cdr x) x))))
|
||||
(context-case ctxt
|
||||
[(value)
|
||||
[(value tail)
|
||||
(bump sc 1)
|
||||
`(case-lambda ,preinfo
|
||||
,(let f ([cl* cl*] [mask 0])
|
||||
|
|
@ -4558,10 +4681,10 @@
|
|||
(f (cdr cl*) new-mask)
|
||||
(cons
|
||||
(with-extended-env ((env x*) (env x* #f))
|
||||
`(clause (,x* ...) ,interface ,(cp0 body 'value env sc wd #f name)))
|
||||
`(clause (,x* ...) ,interface ,(cp0 body 'tail env sc wd #f name)))
|
||||
(f (cdr cl*) new-mask))))])))
|
||||
...)]
|
||||
[(effect) void-rec]
|
||||
[(effect ignored) void-rec]
|
||||
[(test) true-rec]
|
||||
[(app)
|
||||
(with-values (find-lambda-clause ir ctxt)
|
||||
|
|
@ -4591,11 +4714,13 @@
|
|||
(make-if ctxt sc e1
|
||||
true-rec
|
||||
(do-e3))]))
|
||||
(if (eq? (app-ctxt ctxt) 'value)
|
||||
(let ([e1 (value-visit-operand! (car (app-opnds ctxt)))])
|
||||
(and (boolean-valued? e1) (finish e1)))
|
||||
(and (eq? (app-ctxt ctxt) 'test)
|
||||
(finish (test-visit-operand! (car (app-opnds ctxt)))))))]
|
||||
(let ([r-ctxt (app-ctxt ctxt)])
|
||||
(if (or (eq? r-ctxt 'value)
|
||||
(eq? r-ctxt 'tail))
|
||||
(let ([e1 (visit-operand! (car (app-opnds ctxt)) r-ctxt)])
|
||||
(and (boolean-valued? e1) (finish e1)))
|
||||
(and (eq? (app-ctxt ctxt) 'test)
|
||||
(finish (test-visit-operand! (car (app-opnds ctxt))))))))]
|
||||
[else #f]))
|
||||
(cp0-let preinfo ids body ctxt env sc wd name moi))]
|
||||
[() (cp0 ir 'value env sc wd name moi)]))])]
|
||||
|
|
@ -4604,8 +4729,8 @@
|
|||
[(letrec* ([,x* ,e*] ...) ,body)
|
||||
(cp0-rec-let #t x* e* body ctxt env sc wd name moi)]
|
||||
[,pr (context-case ctxt
|
||||
[(value) (bump sc 1) pr]
|
||||
[(effect) void-rec]
|
||||
[(value tail) (bump sc 1) pr]
|
||||
[(effect ignored) void-rec]
|
||||
[(test)
|
||||
(if (all-set? (prim-mask proc) (primref-flags pr))
|
||||
true-rec
|
||||
|
|
@ -4613,16 +4738,17 @@
|
|||
[(app) (fold-primref pr ctxt sc wd name moi)])]
|
||||
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
|
||||
(context-case ctxt
|
||||
[(value app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
|
||||
[(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
|
||||
[(value tail app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
|
||||
[(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd #f moi))]
|
||||
[(test) (make-1seq ctxt (cp0 e 'ignored env sc wd #f moi) true-rec)])]
|
||||
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
|
||||
(context-case ctxt
|
||||
[(value app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
|
||||
[(effect) (cp0 e 'effect env sc wd #f moi)]
|
||||
[(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
|
||||
[(value tail app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
|
||||
[(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd #f moi))]
|
||||
[(test) (make-1seq ctxt (cp0 e 'ignored env sc wd #f moi) true-rec)])]
|
||||
[(record ,rtd ,rtd-expr ,e* ...)
|
||||
(context-case ctxt
|
||||
[(value app)
|
||||
[(value tail app)
|
||||
(let ([rtd-expr (cp0 rtd-expr 'value env sc wd #f moi)]
|
||||
[e* (map (lambda (e) (cp0 e 'value env sc wd #f moi)) e*)])
|
||||
(or (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
|
||||
|
|
@ -4634,26 +4760,26 @@
|
|||
(rtd-flds d))
|
||||
(let ([d* (objs-if-constant e*)])
|
||||
(and d*
|
||||
(make-seq ctxt
|
||||
(make-seq* 'effect (cons rtd-expr e*))
|
||||
(make-1seq ctxt
|
||||
(make-1seq* 'ignored (cons rtd-expr e*))
|
||||
`(quote ,(apply $record d d*))))))]
|
||||
[else #f])
|
||||
`(record ,rtd ,rtd-expr ,e* ...)))]
|
||||
[(effect)
|
||||
(make-seq* ctxt
|
||||
[(effect ignored)
|
||||
(make-1seq* ctxt
|
||||
(cons
|
||||
(cp0 rtd-expr 'effect env sc wd #f moi)
|
||||
(map (lambda (e) (cp0 e 'effect env sc wd #f moi)) e*)))]
|
||||
(cp0 rtd-expr 'ignored env sc wd #f moi)
|
||||
(map (lambda (e) (cp0 e 'ignored env sc wd #f moi)) e*)))]
|
||||
[(test)
|
||||
(make-seq ctxt
|
||||
(make-seq* 'effect
|
||||
(make-1seq ctxt
|
||||
(make-seq* 'ignored
|
||||
(cons
|
||||
(cp0 rtd-expr 'effect env sc wd #f moi)
|
||||
(map (lambda (e) (cp0 e 'effect env sc wd #f moi)) e*)))
|
||||
(cp0 rtd-expr 'ignored env sc wd #f moi)
|
||||
(map (lambda (e) (cp0 e 'ignored env sc wd #f moi)) e*)))
|
||||
true-rec)])]
|
||||
[(record-ref ,rtd ,type ,index ,e)
|
||||
(context-case ctxt
|
||||
[(effect) (cp0 e 'effect env sc wd name moi)]
|
||||
[(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd name moi))]
|
||||
[else
|
||||
(let ([e (cp0 e 'value env sc wd name moi)])
|
||||
(or (nanopass-case (Lsrc Expr) (result-exp e)
|
||||
|
|
@ -4666,8 +4792,8 @@
|
|||
(if (= index 0)
|
||||
(let ([e (car e*)] [e* (rappend re* (cdr e*))])
|
||||
(if (null? e*)
|
||||
e
|
||||
(make-seq ctxt (make-seq* 'effect e*) e)))
|
||||
(make-nontail ctxt e)
|
||||
(make-1seq ctxt (make-seq* 'ignored e*) (make-nontail ctxt e))))
|
||||
(loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))]
|
||||
[else #f])
|
||||
(nanopass-case (Lsrc Expr) (result-exp/indirect-ref e)
|
||||
|
|
@ -4728,7 +4854,7 @@
|
|||
(fluid-let ([likely-to-be-compiled? ltbc?]
|
||||
[opending-list '()]
|
||||
[cp0-info-hashtable (make-weak-eq-hashtable)])
|
||||
(cp0 x 'value empty-env (new-scorer) (new-watchdog) #f #f))]))))
|
||||
(cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))]))))
|
||||
|
||||
; check to make sure all required handlers were seen, after expansion of the
|
||||
; expression above has been completed
|
||||
|
|
|
|||
|
|
@ -135,8 +135,15 @@ Handling letrec and letrec*
|
|||
(values (cons e e*) (and e-pure? e*-pure?)))))
|
||||
(with-output-language (Lsrc Expr)
|
||||
(define build-seq
|
||||
(lambda (e* body)
|
||||
(fold-right (lambda (e body) `(seq ,e ,body)) body e*)))
|
||||
(lambda (pure? e* body)
|
||||
;; Unless `pure?`, wrap `$value` around forms added to a `begin`, so that
|
||||
;; there's a check to make sure they result is a single value. The wrapper
|
||||
;; can be removed by other compiler passes if the argument obviously produces
|
||||
;; a single value.
|
||||
(fold-right (lambda (e body)
|
||||
(let ([e (if pure? e `(call ,(make-preinfo) ,(lookup-primref 3 '$value) ,e))])
|
||||
`(seq ,e ,body)))
|
||||
body e*)))
|
||||
(define build-let
|
||||
(lambda (call-preinfo lambda-preinfo lhs* rhs* body)
|
||||
(if (null? lhs*)
|
||||
|
|
@ -306,7 +313,7 @@ Handling letrec and letrec*
|
|||
(values (if e-pure? pre* (cons e pre*))
|
||||
lhs* rhs* (and e-pure? pure?)))))))])
|
||||
(values
|
||||
(build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
|
||||
(build-seq pure? pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
|
||||
(and body-pure? pure?))))))]
|
||||
[(call ,preinfo ,pr ,e* ...)
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -2673,6 +2673,44 @@
|
|||
[(k ?sym)
|
||||
(with-implicit (k quasiquote)
|
||||
#'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))])))
|
||||
(define single-valued?
|
||||
(case-lambda
|
||||
[(e) (single-valued? e 5)]
|
||||
[(e fuel)
|
||||
(and (not (zero? fuel))
|
||||
(nanopass-case (L7 Expr) e
|
||||
[,x #t]
|
||||
[(immediate ,imm) #t]
|
||||
[(literal ,info) #t]
|
||||
[(label-ref ,l ,offset) #t]
|
||||
[(mref ,e1 ,e2 ,imm) #t]
|
||||
[(quote ,d) #t]
|
||||
[,pr #t]
|
||||
[(call ,info ,mdcl ,pr ,e* ...)
|
||||
(all-set? (prim-mask single-valued) (primref-flags pr))]
|
||||
[(foreign-call ,info ,e, e* ...) #t]
|
||||
[(alloc ,info ,e) #t]
|
||||
[(set! ,lvalue ,e) #t]
|
||||
[(profile ,src) #t]
|
||||
[(pariah) #t]
|
||||
[(let ([,x* ,e*] ...) ,body)
|
||||
(single-valued? body (fx- fuel 1))]
|
||||
[(if ,e0 ,e1 ,e2)
|
||||
(and (single-valued? e1 (fx- fuel 1))
|
||||
(single-valued? e2 (fx- fuel 1)))]
|
||||
[(seq ,e0 ,e1)
|
||||
(single-valued? e1 (fx- fuel 1))]
|
||||
[else #f]))]))
|
||||
(define ensure-single-valued
|
||||
(case-lambda
|
||||
[(e unsafe-omit?)
|
||||
(if (or unsafe-omit?
|
||||
(single-valued? e))
|
||||
e
|
||||
(with-output-language (L7 Expr)
|
||||
(let ([t (make-tmp 'v)])
|
||||
`(values ,(make-info-call #f #f #f #f #f) ,e))))]
|
||||
[(e) (ensure-single-valued e (fx= (optimize-level) 3))]))
|
||||
(define-pass np-expand-primitives : L7 (ir) -> L9 ()
|
||||
(Program : Program (ir) -> Program ()
|
||||
[(labels ([,l* ,le*] ...) ,l)
|
||||
|
|
@ -3805,8 +3843,10 @@
|
|||
[else #f]))]
|
||||
[else #f])))
|
||||
(define-inline 2 values
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)])
|
||||
(define-inline 2 $value
|
||||
[(e) (ensure-single-valued e #f)])
|
||||
(define-inline 2 eq?
|
||||
[(e1 e2) (%inline eq? ,e1 ,e2)])
|
||||
(define-inline 2 $keep-live
|
||||
|
|
@ -3879,7 +3919,7 @@
|
|||
reduce-equality
|
||||
reduce-inequality))
|
||||
(define-inline 3 op
|
||||
[(e) `(seq ,e ,(%constant strue))]
|
||||
[(e) `(seq ,(ensure-single-valued e) ,(%constant strue))]
|
||||
[(e1 e2) (go e1 e2)]
|
||||
[(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])
|
||||
(define-inline 3 r6rs:op
|
||||
|
|
@ -3896,7 +3936,7 @@
|
|||
[(_ op inline-op base)
|
||||
(define-inline 3 op
|
||||
[() `(immediate ,(fix base))]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (%inline inline-op ,e1 ,e2)]
|
||||
[(e1 . e*) (reduce src sexpr moi e1 e*)])]))
|
||||
(fxlogop fxlogand logand -1)
|
||||
|
|
@ -3994,7 +4034,7 @@
|
|||
(%inline u< ,e1 ,e2))])
|
||||
(define-inline 3 fx+
|
||||
[() `(immediate 0)]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (%inline + ,e1 ,e2)]
|
||||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
(define-inline 3 r6rs:fx+ ; limited to two arguments
|
||||
|
|
@ -4174,7 +4214,7 @@
|
|||
(%inline * ,e1 ,t))))])]))
|
||||
(define-inline 3 fx*
|
||||
[() `(immediate ,(fix 1))]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (build-fx* e1 e2 #f)]
|
||||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
(define-inline 3 r6rs:fx* ; limited to two arguments
|
||||
|
|
@ -4592,7 +4632,7 @@
|
|||
; [(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
|
||||
(define-inline 3 fxmin
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (bind #t (e1 e2)
|
||||
`(if ,(%inline < ,e1 ,e2)
|
||||
,e1
|
||||
|
|
@ -4600,7 +4640,7 @@
|
|||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
|
||||
(define-inline 3 fxmax
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (bind #t (e1 e2)
|
||||
`(if ,(%inline < ,e2 ,e1)
|
||||
,e1
|
||||
|
|
@ -4867,10 +4907,10 @@
|
|||
,(%inline + ,t (immediate ,next-i)))
|
||||
,(loop e2 e* next-i)))))))))))
|
||||
(define-inline 2 list*
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e . e*) (go e e*)])
|
||||
(define-inline 2 cons*
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e . e*) (go e e*)]))
|
||||
(define-inline 2 vector
|
||||
[() `(quote #())]
|
||||
|
|
@ -6524,13 +6564,13 @@
|
|||
;; allocated across nested fl+, fl*, fl-, fl/ etc. operation
|
||||
(define-inline 3 fl+
|
||||
[() `(quote 0.0)]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (bind #f (e1 e2) (build-flop-2 %fl+ e1 e2))]
|
||||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
|
||||
(define-inline 3 fl*
|
||||
[() `(quote 1.0)]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (bind #f (e1 e2) (build-flop-2 %fl* e1 e2))]
|
||||
[(e1 . e*) (reduce src sexpr moi e1 e*)])
|
||||
|
||||
|
|
@ -6593,7 +6633,7 @@
|
|||
|
||||
(define-inline 3 cfl+
|
||||
[() `(quote 0.0)]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)]
|
||||
; TODO: add 3 argument version of cfl+ library function
|
||||
#;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)]
|
||||
|
|
@ -6601,7 +6641,7 @@
|
|||
|
||||
(define-inline 3 cfl*
|
||||
[() `(quote 1.0)]
|
||||
[(e) e]
|
||||
[(e) (ensure-single-valued e)]
|
||||
[(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)]
|
||||
; TODO: add 3 argument version of cfl* library function
|
||||
#;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)]
|
||||
|
|
|
|||
|
|
@ -13,10 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define generate-procedure-source-information
|
||||
(case-lambda
|
||||
[() #f]
|
||||
[(v) (void)]))
|
||||
(define ($value x) x)
|
||||
|
||||
(printf "loading ~s cross compiler~%" (constant machine-type-name))
|
||||
|
||||
|
|
|
|||
|
|
@ -61,9 +61,9 @@
|
|||
(fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard])
|
||||
(fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
|
||||
(fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
|
||||
(fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02])
|
||||
(fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
|
||||
(fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
|
||||
(fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02])
|
||||
(fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02])
|
||||
(fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
(fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
(acos [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(atan [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags arith-op mifoldable discard])
|
||||
(exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
|
||||
(expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
|
||||
(make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
(make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
|
||||
|
|
@ -530,7 +530,7 @@
|
|||
(hashtable-copy [sig [(hashtable) (hashtable ptr) -> (hashtable)]] [flags alloc])
|
||||
(hashtable-clear! [sig [(hashtable) (hashtable sub-uint) -> (void)]] [flags true])
|
||||
(hashtable-keys [sig [(hashtable) -> (vector)]] [flags alloc])
|
||||
(hashtable-entries [sig [(hashtable) -> (vector vector)]] [flags alloc])
|
||||
(hashtable-entries [sig [(hashtable) -> (vector vector)]] [flags discard])
|
||||
(hashtable-equivalence-function [sig [(hashtable) -> (ptr)]] [flags])
|
||||
(hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags])
|
||||
(hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard])
|
||||
|
|
@ -613,7 +613,7 @@
|
|||
(open-file-output-port [sig [(pathname) (pathname file-options) (pathname file-options sub-symbol) (pathname file-options sub-symbol maybe-transcoder) -> (output-port)]] [flags true])
|
||||
(open-bytevector-output-port [sig [() (maybe-transcoder) -> (output-port procedure)]] [flags discard])
|
||||
(call-with-bytevector-output-port [sig [(procedure) (procedure maybe-transcoder) -> (bytevector)]] [flags])
|
||||
(open-string-output-port [sig [() -> (textual-output-port procedure)]] [flags alloc])
|
||||
(open-string-output-port [sig [() -> (textual-output-port procedure)]] [flags discard])
|
||||
(call-with-string-output-port [sig [(procedure) -> (string)]] [flags])
|
||||
((r6rs: standard-output-port) [sig [() -> (binary-output-port)]] [flags true])
|
||||
((r6rs: standard-error-port) [sig [() -> (binary-output-port)]] [flags true])
|
||||
|
|
@ -900,7 +900,7 @@
|
|||
(most-positive-fixnum [sig [() -> (ufixnum)]] [flags pure unrestricted true cp02])
|
||||
(petite? [sig [() -> (boolean)]] [flags pure unrestricted])
|
||||
(scheme-version [sig [() -> (string)]] [flags pure unrestricted true])
|
||||
(scheme-version-number [sig [() -> (uint uint uint)]] [flags pure unrestricted true])
|
||||
(scheme-version-number [sig [() -> (uint uint uint)]] [flags discard unrestricted])
|
||||
(threaded? [sig [() -> (boolean)]] [flags pure unrestricted cp02])
|
||||
)
|
||||
|
||||
|
|
@ -2041,7 +2041,7 @@
|
|||
($lexical-error [flags])
|
||||
($library-requirements-options [flags])
|
||||
($library-search [flags])
|
||||
($list-length [flags])
|
||||
($list-length [flags single-valued])
|
||||
($load-library [flags])
|
||||
($locate-source [flags])
|
||||
($logand [flags])
|
||||
|
|
@ -2210,7 +2210,7 @@
|
|||
($system-library? [flags])
|
||||
($system-procedure? [flags])
|
||||
($system-property-list [flags])
|
||||
($tc-field [flags])
|
||||
($tc-field [flags single-valued])
|
||||
($tc [flags])
|
||||
($thread-list [flags])
|
||||
($thread-tc [flags])
|
||||
|
|
@ -2218,8 +2218,8 @@
|
|||
($tlc-ht [flags mifoldable discard])
|
||||
($tlc-keyval [flags pure mifoldable discard])
|
||||
($tlc-next [flags mifoldable discard])
|
||||
($top-level-bound? [flags discard])
|
||||
($top-level-value [flags discard cp02])
|
||||
($top-level-bound? [flags discard single-valued])
|
||||
($top-level-value [flags discard cp02 single-valued])
|
||||
($trace-closure [flags pure alloc])
|
||||
($trace [flags])
|
||||
($track-dynamic-closure-counts [flags]) ; added for closure instrumentation
|
||||
|
|
@ -2239,6 +2239,7 @@
|
|||
($undefined-violation [flags abort-op])
|
||||
($untrace [flags])
|
||||
($unwrap-ftype-pointer [flags])
|
||||
($value [flags unrestricted discard single-valued cp02])
|
||||
($vector-ref-check? [flags])
|
||||
($vector-set!-check? [flags])
|
||||
($vector-set-immutable! #;[sig [(vector) -> (ptr)]] [flags true])
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec get-priminfo priminfo-boolean?)
|
||||
(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec
|
||||
get-priminfo priminfo-boolean? priminfo-result-arity)
|
||||
(define-record-type priminfo
|
||||
(nongenerative)
|
||||
(sealed #t)
|
||||
|
|
@ -37,7 +38,22 @@
|
|||
(andmap (lambda (sig)
|
||||
(let ([out (cdr sig)])
|
||||
(and (pair? out) (eq? (car out) 'boolean) (null? (cdr out)))))
|
||||
signature*)))))
|
||||
signature*)))))
|
||||
|
||||
(define priminfo-result-arity
|
||||
(lambda (info)
|
||||
(let ([signature* (priminfo-signatures info)])
|
||||
(cond
|
||||
[(null? signature*) 'unknown]
|
||||
[(andmap (lambda (sig)
|
||||
(let ([out (cdr sig)])
|
||||
(and (pair? out) (null? (cdr out)))))
|
||||
signature*)
|
||||
;; Note that a `(bottom)` result is treated as single-valued,
|
||||
;; which is ok in the sense that the aborting operation will
|
||||
;; produce a single value when it (never) returns.
|
||||
'single]
|
||||
[else 'multiple]))))
|
||||
|
||||
(define signature->interface
|
||||
(lambda (sig)
|
||||
|
|
|
|||
|
|
@ -340,6 +340,12 @@
|
|||
|
||||
(define values ($hand-coded 'values-procedure))
|
||||
|
||||
;; When applied, ensures the argument expression produces a single
|
||||
;; value. Unlike other primitives, an immediate application of
|
||||
;; `$value` won't be optimized away with optimization level 3 unless
|
||||
;; the argument expression definitely produces a single value.
|
||||
(define $value (lambda (x) x))
|
||||
|
||||
(define call-with-values
|
||||
(lambda (producer consumer)
|
||||
(unless (procedure? producer)
|
||||
|
|
|
|||
|
|
@ -18,10 +18,13 @@
|
|||
(include "primref.ss")
|
||||
|
||||
(define record-prim!
|
||||
(lambda (prim unprefixed flags arity boolean-valued?)
|
||||
(lambda (prim unprefixed flags arity boolean-valued? result-arity)
|
||||
(unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed))
|
||||
(let ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)]
|
||||
[arity (and (not (null? arity)) arity)])
|
||||
(let* ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)]
|
||||
[flags (if (eq? 'single result-arity) (fxlogor flags (prim-mask single-valued)) flags)]
|
||||
[arity (and (not (null? arity)) arity)])
|
||||
(when (and (eq? result-arity 'multiple) (any-set? (prim-mask single-valued) flags))
|
||||
($oops 'prims "inconsistent single-value information for ~s" prim))
|
||||
($sputprop prim '*flags* flags)
|
||||
(when (any-set? (prim-mask (or primitive system)) flags)
|
||||
($sputprop prim '*prim2* (make-primref prim flags arity))
|
||||
|
|
@ -38,7 +41,8 @@
|
|||
'#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-mask v-info))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-arity v-info))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-boolean? v-info)))))))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-boolean? v-info))
|
||||
'#,(datum->syntax #'* (vector-map priminfo-result-arity v-info)))))))
|
||||
|
||||
(for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist))
|
||||
setup)
|
||||
|
|
|
|||
|
|
@ -8757,7 +8757,7 @@
|
|||
;; but tell `$foreign-procedure` that the result is actually an & form
|
||||
#`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))]
|
||||
[else
|
||||
#`(values #,(datum->syntax #'foreign-procedure result-type))])])]
|
||||
#`(begin #,(datum->syntax #'foreign-procedure result-type))])])]
|
||||
[([extra ...] [extra-arg ...] [extra-check ...])
|
||||
;; When the result type is `(& <ftype>)`, the `$foreign-procedure` result
|
||||
;; expects an extra argument as a `(* <ftype>)` that it uses to store the
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user