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

add $app

Browse Source 
Using `#3%$app` disables a `procedure?` check in an application.

original commit: d7960da9e3c3a864a4df42cb8bb71d9b205aeb95
This commit is contained in:
Matthew Flatt 2019-09-18 20:19:41 -06:00
parent ee7efa1dc3
commit 4e3b829227
17 changed files with 80 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
c/fasl.c
View File

@ -405,13 +405,17 @@ static uptr uf_uptrin(unbufFaslFile uf) {
}
char *S_format_scheme_version(uptr n) {
static char buf[16]; INT len;
if ((n >> 16) != ((n >> 16) & 0xffff)) return "unknown";
if ((n & 0xff) == 0)
len = snprintf(buf, 16, "%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff);
else
len = snprintf(buf, 16, "%d.%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff,
(int) n & 0xff);
static char buf[20]; INT len;
if ((n >> 24) != ((n >> 24) & 0xffff)) return "unknown";
if ((n & 0xff) == 0) {
if ((n & 0xff) == 0)
len = snprintf(buf, 20, "%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff);
else
len = snprintf(buf, 20, "%d.%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff,
(int) (n >> 8) & 0xff);
} else
len = snprintf(buf, 20, "%d.%d.%d.%d", (int) n >> 24, (int) (n >> 16) & 0xff,
(int) (n >> 8) & 0xff, (int) n & 0xff);
return len > 0 ? buf : "unknown";
}

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.3.1
Version=csv9.5.3.2
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

14
s/base-lang.ss
View File

@ -18,6 +18,7 @@
sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags
preinfo-lambda-flags-set! preinfo-lambda-libspec
make-preinfo-call preinfo-call? preinfo-call-check?
prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
target-fixnum? target-bignum?)
@ -183,6 +184,19 @@
[(src sexpr libspec name) ((pargs->new src sexpr) libspec name 0)]
[(src sexpr libspec name flags) ((pargs->new src sexpr) libspec name flags)]))))
(define-record-type preinfo-call
(nongenerative #{preinfo-call e23pkvo5btgapnzomqgegm-7})
(parent preinfo)
(sealed #t)
(fields check?)
(protocol
(lambda (pargs->new)
(case-lambda
[() ((pargs->new) #t)]
[(src) ((pargs->new src) #t)]
[(src sexpr) ((pargs->new src sexpr) #t)]
[(src sexpr check?) ((pargs->new src sexpr) check?)]))))
; language of foreign types
(define-language Ltype
(nongenerative-id #{Ltype czp82kxwe75y4e18-1})

2
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x09050301)
(define-constant scheme-version #x09050302)
(define-syntax define-machine-types
(lambda (x)

4
s/compile.ss
View File

@ -1098,7 +1098,7 @@
(define gen-var (lambda (sym) (make-prelex sym 0 #f #f)))
(define build-let
(lambda (ids exprs body)
`(call ,(make-preinfo) ,(build-lambda ids body) ,exprs ...)))
`(call ,(make-preinfo-call) ,(build-lambda ids body) ,exprs ...)))
(define build-lambda
(lambda (ids body)
@ -1107,7 +1107,7 @@
(define build-call
(lambda (e . e*)
`(call ,(make-preinfo) ,e ,e* ...)))
`(call ,(make-preinfo-call) ,e ,e* ...)))
(define-syntax build-primcall
; written as a macro to give lookup-primref a chance to lookup the primref at expansion time

33
s/cp0.ss
View File

@ -673,7 +673,7 @@
(module (build-primcall)
(define $build-primcall
(case-lambda
[(primref args) ($build-primcall (make-preinfo) primref args)]
[(primref args) ($build-primcall (make-preinfo-call) primref args)]
[(preinfo primref args) `(call ,preinfo ,primref ,args ...)]))
(define-syntax build-primcall
(syntax-rules ()
@ -718,12 +718,12 @@
(define build-let
(case-lambda
[(lambda-preinfo ids exps body)
(build-call (make-preinfo) (build-lambda lambda-preinfo ids body) exps)]
[(ids exps body) (build-call (make-preinfo) (build-lambda ids body) exps)]))
(build-call (make-preinfo-call) (build-lambda lambda-preinfo ids body) exps)]
[(ids exps body) (build-call (make-preinfo-call) (build-lambda ids body) exps)]))
(define build-named-let
(lambda (name ids exps body)
`(call ,(make-preinfo)
`(call ,(make-preinfo-call)
(letrec ([,name ,(build-lambda ids body)])
(ref #f ,name))
,exps ...)))
@ -4106,7 +4106,7 @@
,(map (lambda (x)
(build-primcall 3 'car (list (build-ref x))))
ls*) ...)
`(call ,(make-preinfo) (ref #f ,do) (ref #f ,r)
`(call ,(make-preinfo-call) (ref #f ,do) (ref #f ,r)
,(map (lambda (x)
(build-primcall 3 'cdr (list (build-ref x))))
(cdr ls*)) ...)))))))))
@ -4229,7 +4229,7 @@
(build-primcall 3 'vector-ref
(list (build-ref x) (build-ref i))))
(cons v v*)) ...)
`(call ,(make-preinfo) (ref #f ,do) (ref #f ,j))))))))))
`(call ,(make-preinfo-call) (ref #f ,do) (ref #f ,j))))))))))
ctxt empty-env sc wd name moi))])])
(define-inline 3 string-for-each ; should combine with vector-for-each
@ -4304,7 +4304,7 @@
(build-primcall 3 'string-ref
(list (build-ref x) (build-ref i))))
(cons s s*)) ...)
`(call ,(make-preinfo) (ref #f ,do) (ref #f ,j))))))))))
`(call ,(make-preinfo-call) (ref #f ,do) (ref #f ,j))))))))))
ctxt empty-env sc wd name moi))])])
(define-inline 3 fold-right
@ -4349,7 +4349,7 @@
(ref #f ,acc)
,(map build-ref carls*)
...)
(call ,(make-preinfo) (ref #f ,do)
(call ,(make-preinfo-call) (ref #f ,do)
(call ,(app-preinfo ctxt) (ref #f ,p)
(ref #f ,acc)
,(map build-ref carls*)
@ -4396,7 +4396,7 @@
(build-primcall 3 'car
(list (build-ref x))))
ls*) ...)
(call ,(make-preinfo) (ref #f ,do) (ref #f ,r)
(call ,(make-preinfo-call) (ref #f ,do) (ref #f ,r)
,(map (lambda (x)
(build-primcall 3 'cdr
(list (build-ref x))))
@ -4445,7 +4445,7 @@
ls*) ...))
`(if (ref #f ,t)
(ref #f ,t)
(call ,(make-preinfo) (ref #f ,do) (ref #f ,r)
(call ,(make-preinfo-call) (ref #f ,do) (ref #f ,r)
,(map (lambda (x)
(build-primcall 3 'cdr
(list (build-ref x))))
@ -4596,11 +4596,11 @@
(let ([orig-x (cp0-make-temp #f)] [p (cp0-make-temp #t)])
(build-lambda (list orig-x p)
(maybe-add-procedure-check ?p level "make-parameter" p
(build-let (list x) (list `(call ,(make-preinfo) (ref #f ,p) (ref #f ,orig-x)))
(build-let (list x) (list `(call ,(make-preinfo-call) (ref #f ,p) (ref #f ,orig-x)))
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
(list
(list '() (build-ref x))
(list (list v) `(set! #f ,x (call ,(make-preinfo) (ref #f ,p) (ref #f ,v))))))))))
(list (list v) `(set! #f ,x (call ,(make-preinfo-call) (ref #f ,p) (ref #f ,v))))))))))
(build-lambda (list x)
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
(list
@ -4639,11 +4639,11 @@
(maybe-add-procedure-check ?p level "make-thread-parameter" p
(build-let (list x)
(list (build-primcall 3 '$allocate-thread-parameter
(list `(call ,(make-preinfo) (ref #f ,p) (ref #f ,orig-x)))))
(list `(call ,(make-preinfo-call) (ref #f ,p) (ref #f ,orig-x)))))
(build-case-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt))
(list
(list '() (mtp-ref x))
(list (list v) (mtp-set x `(call ,(make-preinfo) (ref #f ,p) (ref #f ,v))))))))))
(list (list v) (mtp-set x `(call ,(make-preinfo-call) (ref #f ,p) (ref #f ,v))))))))))
(build-lambda (list orig-x)
(build-let (list x)
(list (build-primcall 3 '$allocate-thread-parameter
@ -4829,6 +4829,11 @@
;; 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 ,pr ,e ,e* ...)
(guard (eq? (primref-name pr) '$app))
(let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo)
(not (all-set? (prim-mask unsafe) (primref-flags pr))))])
(cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))]
[(call ,preinfo ,e ,e* ...)
(let ()
(define lift-let

12
s/cpcheck.ss
View File

@ -169,10 +169,10 @@
,(Expr body ctxt)))]
[,pr (let ([arity (primref-arity pr)]) (when arity (check! ctxt arity))) pr]
[(record-ref ,rtd ,type ,index ,[e #f -> e])
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-ref)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-ref)
(quote ,type) ,e (quote ,(record-field-offset rtd index)))]
[(record-set! ,rtd ,type ,index ,[e1 #f -> e1] ,[e2 #f -> e2])
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!)
(quote ,type) ,e1 (quote ,(record-field-offset rtd index)) ,e2)]
[(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
(let ([rtd (maybe-remake-rtd rtd)])
@ -184,19 +184,19 @@
(if (eq? (filter-foreign-type type) 'scheme-object)
filler*
(cons
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$object-set!)
(quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
filler*))))
'() fld* e*)])
(if (null? filler*)
`(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
(begin
(set-prelex-referenced! rec-t #t)
(set-prelex-multiply-referenced! rec-t #t)
`(call ,(make-preinfo)
`(call ,(make-preinfo-call)
(case-lambda ,(make-preinfo-lambda)
(clause (,rec-t) 1 ,(build-sequence filler* `(ref #f ,rec-t))))
(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr
(call ,(make-preinfo-call) ,(lookup-primref 3 '$record) ,rtd-expr
,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg]))
(make-record-call-args fld* (rtd-size rtd) e*))
...)))))))]

2
s/cpcommonize.ss
View File

@ -547,7 +547,7 @@
(nanopass-case (Lcommonize1 Expr) (binding-e helper-b)
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
(loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))])
`(call ,(make-preinfo)
`(call ,(make-preinfo-call)
,(let ([t (binding-x helper-b)])
(if (prelex-referenced t)
(set-prelex-multiply-referenced! t #t)

6
s/cpletrec.ss
View File

@ -141,7 +141,7 @@ Handling letrec and letrec*
;; 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))])
(let ([e (if pure? e `(call ,(make-preinfo-call) ,(lookup-primref 3 '$value) ,e))])
`(seq ,e ,body)))
body e*)))
(define build-let
@ -232,7 +232,7 @@ Handling letrec and letrec*
(cons lhs lhs*)
lhs*)))
'() cb*)])
(build-let (make-preinfo) (make-preinfo-lambda) rclhs* (map (lambda (x) `(quote ,(void))) rclhs*)
(build-let (make-preinfo-call) (make-preinfo-lambda) rclhs* (map (lambda (x) `(quote ,(void))) rclhs*)
(build-letrec (map binding-lhs lb*) (map binding-rhs lb*)
(fold-right (lambda (b body)
(let ([lhs (binding-lhs b)] [rhs (binding-rhs b)])
@ -262,7 +262,7 @@ Handling letrec and letrec*
[(and (not (prelex-assigned lhs)) (lambda? rhs))
(build-letrec (list lhs) (list rhs) body)]
[(not (memq b (node-link* b)))
(build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body)]
(build-let (make-preinfo-call) (make-preinfo-lambda) (list lhs) (list rhs) body)]
[else (grisly-letrec '() b* body)]))
(let-values ([(lb* cb*) (partition
(lambda (b)

3
s/cpnanopass.ss
View File

@ -1051,7 +1051,8 @@
(let ([e* (map CaseLambdaExpr e* uvar*)])
`(letrec ([,uvar* ,e*] ...) ,(Expr body))))]
[(call ,preinfo ,e ,[e*] ...)
`(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f)
(unless (preinfo-call? preinfo) (error 'preinfo-call "oops"))
`(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (preinfo-call-check? preinfo) #f #f)
,(Expr e) ,e* ...)]
[(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
(let ([info (make-info-foreign conv* arg-type* result-type)])

8
s/cprep.ss
View File

@ -157,7 +157,13 @@
[(call ,preinfo ,e ,e* ...)
(cache-sexpr preinfo
(lambda ()
`(,(uncprep e) ,@(map uncprep e*))))]
(let ([a `(,(uncprep e) ,@(map uncprep e*))])
(if (or (preinfo-call-check? preinfo)
;; Reporting `#3%$app` is redundant for unsafe mode.
;; Note that we're losing explicit `#2%$app`s.
(>= (optimize-level) 3))
a
(cons '#3%$app a)))))]
[,pr (let ([sym (primref-name pr)])
(if sexpr?
($sgetprop sym '*unprefixed* sym)

4
s/cpvalid.ss
View File

@ -32,7 +32,7 @@
(lambda (ids vals body)
(if (null? ids)
body
`(call ,(make-preinfo)
`(call ,(make-preinfo-call)
(case-lambda ,(make-preinfo-lambda)
(clause (,ids ...) ,(length ids) ,body))
,vals ...))))
@ -205,7 +205,7 @@
`(seq
(if (ref #f ,valid-flag)
(quote ,(void))
(call ,(make-preinfo) ,(lookup-primref 2 '$source-violation)
(call ,(make-preinfo-call) ,(lookup-primref 2 '$source-violation)
(quote #f)
(quote ,maybe-src)
(quote #t)

2
s/interpret.ss
View File

@ -95,7 +95,7 @@
(lambda (ids vals body)
(if (null? ids)
body
`(call ,(make-preinfo)
`(call ,(make-preinfo-call)
(case-lambda ,(make-preinfo-lambda)
(clause (,ids ...) ,(length ids) ,body))
,vals ...))))

1
s/np-languages.ss
View File

@ -73,6 +73,7 @@
Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc
lookup-primref primref? primref-level primref-name primref-flags primref-arity
preinfo-src preinfo-sexpr preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec
preinfo-call? preinfo-call-check?
prelex-name prelex-name-set!)
(import (nanopass))

1
s/primdata.ss
View File

@ -1756,6 +1756,7 @@
($address-in-heap? [flags])
($address->object [flags])
($allocate-thread-parameter [feature pthreads] [flags alloc])
($app [flags])
($apply [flags])
($assembly-output [flags])
($as-time-goes-by [flags])

7
s/prims.ss
View File

@ -357,6 +357,13 @@
;; the argument expression definitely produces a single value.
(define $value (lambda (x) x))
;; Intended mainly for use as `#3%$app` to indicate that no check
;; is needed to ensure that the first argument is a function, as
;; recognized in cp0.
(define $app
(lambda (f . args)
(#2%apply f args)))
(define call-with-values
(lambda (producer consumer)
(unless (procedure? producer)

2
s/syntax.ss
View File

@ -550,7 +550,7 @@
(define build-call
(lambda (ae e e*)
(build-profile ae
`(call ,(make-preinfo (ae->src ae) #f) ,e ,e* ...))))
`(call ,(make-preinfo-call (ae->src ae) #f (fx< (optimize-level) 3)) ,e ,e* ...))))
(define build-application
; used by chi-application. pulls profile form off e if e is a lambda expression