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

Merge pull request #147 from mflatt/arity

Browse Source 
Add `procedure-arity-mask`
original commit: e5802671c91378a91c3404f62e0e452590a975b7
This commit is contained in:
R. Kent Dybvig 2017-02-22 12:59:32 -05:00 committed by GitHub
commit 29351926fa
20 changed files with 145 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
LOG
View File

@ -335,3 +335,13 @@
BUILDING, install/* (removed), wininstall/* (new)
- updated zlib to version 1.2.11
configure
- added procedure-arity-mask to report the allowed argument counts of
a compiled function. On a procedure from interpret or from one of
the trace procedures or syntactic forms, procedure-arity-mask
may report counts that are not actually allowed by the source
procedure.
cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss,
prims.ss, strip.ss,
fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c,
misc.ms, root-experr*,
objects.stex

2
c/fasl.c
View File

@ -97,6 +97,7 @@
* <uptr free> # number of free variables
* <uptr n> # length in bytes of code
* <fasl name>
* <fasl arity-mask> # two's complement encoding of accepted argument counts
* <fasl info> # inspector info
* <fasl pinfo*> # profiling info
* <byte code1>...<byte coden>
@ -839,6 +840,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
faslin(tc, &name, t, pstrbuf, f);
if (Sstringp(name)) name = SYMNAME(S_intern_sc(&STRIT(name, 0), Sstring_length(name), name));
CODENAME(co) = name;
faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f);
faslin(tc, &CODEINFO(co), t, pstrbuf, f);
faslin(tc, &CODEPINFOS(co), t, pstrbuf, f);
bytesin((octet *)&CODEIT(co, 0), n, f);

1
c/gc.c
View File

@ -1602,6 +1602,7 @@ static void sweep_code_object(tc, co) ptr tc, co; {
#endif
relocate(&CODENAME(co))
relocate(&CODEARITYMASK(co))
relocate(&CODEINFO(co))
relocate(&CODEPINFOS(co))

1
c/globals.h
View File

@ -107,7 +107,6 @@ EXTERN struct {
ptr nuate_id;
ptr null_continuation_id;
ptr collect_request_pending_id;
ptr dummy_continuation_code;
/* gc.c */
ptr guardians[static_generation+1];

1
c/prim.c
View File

@ -211,6 +211,7 @@ static void s_instantiate_code_object() {
CODERELOC(new) = newreloc;
CODENAME(new) = CODENAME(old);
CODEARITYMASK(new) = CODEARITYMASK(old);
CODEFREE(new) = CODEFREE(old);
CODEINFO(new) = CODEINFO(old);
CODEPINFOS(new) = CODEPINFOS(old);

7
c/prim5.c
View File

@ -57,7 +57,7 @@ static void s_set_code_long2 PROTO((ptr p, ptr n, ptr h, ptr l));
static ptr s_set_code_quad PROTO((ptr p, ptr n, ptr x));
static ptr s_set_reloc PROTO((ptr p, ptr n, ptr e));
static ptr s_flush_instruction_cache PROTO((void));
static ptr s_make_code PROTO((iptr flags, iptr free, ptr name, iptr n, ptr info, ptr pinfos));
static ptr s_make_code PROTO((iptr flags, iptr free, ptr name, ptr arity_mark, iptr n, ptr info, ptr pinfos));
static ptr s_make_reloc_table PROTO((ptr codeobj, ptr n));
static ptr s_make_closure PROTO((ptr offset, ptr codeobj));
static ptr s_fxrandom PROTO((ptr n));
@ -847,8 +847,8 @@ static ptr s_flush_instruction_cache() {
return Svoid;
}
static ptr s_make_code(flags, free, name, n, info, pinfos)
iptr flags, free, n; ptr name, info, pinfos; {
static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos)
iptr flags, free, n; ptr name, arity_mark, info, pinfos; {
ptr co;
tc_mutex_acquire()
@ -856,6 +856,7 @@ static ptr s_make_code(flags, free, name, n, info, pinfos)
tc_mutex_release()
CODEFREE(co) = free;
CODENAME(co) = name;
CODEARITYMASK(co) = arity_mark;
CODEINFO(co) = info;
CODEPINFOS(co) = pinfos;
return co;

1
c/scheme.c
View File

@ -98,6 +98,7 @@ static void main_init() {
p = S_code(tc, type_code, size_rp_header);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;

4
c/schsig.c
View File

@ -673,13 +673,11 @@ void S_schsig_init() {
p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;
S_protect(&S_G.dummy_continuation_code);
S_G.dummy_continuation_code = p;
S_set_symbol_value(S_G.null_continuation_id,
S_mkcontinuation(space_new,
0,

31
csug/objects.stex
View File

@ -3161,3 +3161,34 @@ rtd ;=> #<record type frob>
\endschemedisplay
\section{Procedures}
%----------------------------------------------------------------------------
\noskipentryheader
\formdef{procedure-arity-mask}{\categoryprocedure}{(procedure-arity-mask \var{proc})}
\returns an exact integer bitmask identifying the accepted argument counts of \var{proc}
\listlibraries
\endentryheader
\noindent
The bitmask is represented as two's complement number with the bit
at each index \var{n} set if and only if \var{proc} accepts \var{n}
arguments.
The two's complement encoding implies that if \var{proc} accepts
\var{n} or more arguments, the encoding is a negative number,
since all the bits from \var{n} and up are set. For example, if
\var{proc} accepts any number of arguments, the two's complement
encoding of all bits set is \scheme{-1}.
\schemedisplay
(procedure-arity-mask (lambda () 'none)) ;=> 1
(procedure-arity-mask car) ;=> 2
(procedure-arity-mask (case-lambda [() 'none] [(x) x])) ;=> 3
(procedure-arity-mask (lambda x x)) ;=> -1
(procedure-arity-mask (case-lambda [() 'none] [(x y . z) x])) ;=> -3
(procedure-arity-mask (case-lambda)) ;=> 0
(logbit? 1 (procedure-arity-mask pair?)) ;=> #t
(logbit? 2 (procedure-arity-mask pair?)) ;=> #f
(logbit? 2 (procedure-arity-mask cons)) ;=> #t
\endschemedisplay

38
mats/misc.ms
View File

@ -4889,3 +4889,41 @@
(fx+ success 1)
success)))))))
)
(mat procedure-arity-mask
(equal? (procedure-arity-mask (lambda () #f)) 1)
(equal? (procedure-arity-mask (lambda (x) x)) 2)
(equal? (procedure-arity-mask (lambda (x y z w) x)) 16)
(or (eq? (current-eval) interpret)
(equal? (procedure-arity-mask (lambda (x y z w a b c d e f g h i j) x)) (ash 1 14)))
(or (eq? (current-eval) interpret)
(and
(equal? (procedure-arity-mask (case-lambda)) 0)
(equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y])) 6)
(equal? (procedure-arity-mask (case-lambda [() x] [(x . y) y])) -1)
(equal? (procedure-arity-mask (case-lambda [() x] [(x y . z) y])) (bitwise-not 2))
(equal? (procedure-arity-mask (case-lambda [(x y . z) y] [() x])) (bitwise-not 2))
(equal? (procedure-arity-mask (case-lambda [(x) x] [(x y) y] [(x y z) z])) 14)))
(equal? (procedure-arity-mask list) -1)
(equal? (procedure-arity-mask cons) 4)
(equal? (procedure-arity-mask list*) (bitwise-not 1))
(equal? (procedure-arity-mask +) -1)
(equal? (procedure-arity-mask -) -2)
(equal? (procedure-arity-mask max) -2)
(equal? (call/cc procedure-arity-mask) -1)
(equal? (call/1cc procedure-arity-mask) -1)
(equal? (procedure-arity-mask #%$null-continuation) 0)
(equal?
(parameterize ([enable-cp0 #t]) (compile '(procedure-arity-mask
(case-lambda [a a] [(b) b]))))
-1)
(equal?
(parameterize ([enable-cp0 #f]) (compile '(procedure-arity-mask
(case-lambda [a a] [(b) b]))))
-1)
(error? ; invalid argument
(procedure-arity-mask 17))
)

1
mats/root-experr-compile-0-f-f-f
View File

@ -3732,6 +3732,7 @@ misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid
misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid index 0.0".
misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".

1
mats/root-experr-compile-2-f-f-f
View File

@ -3730,6 +3730,7 @@ misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid
misc.mo:Expected error in mat virtual-registers: "set-virtual-register!: invalid index 0.0".
misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".

10
release_notes/release_notes.stex
View File

@ -58,6 +58,16 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{\protect\scheme{procedure-arity-mask} (9.4.1)}
The new primitive procedure \scheme{procedure-arity-mask} takes a
procedure \var{p} and returns a two's complement bitmask representing
the argument counts accepted by \var{p}.
For example, the arity mask for a two-argument procedure such as
\var{cons} is $4$ (only bit two set),
while the arity mask for a procedure that accepts one or more arguments,
such as \var{list*}, is $-2$ (all but bit 0 set).
\subsection{High-precision clock time in Windows 8 and up (9.4.1)}
When running on Windows 8 and up, Chez Scheme uses the high-precision

1
s/cmacros.ss
View File

@ -1208,6 +1208,7 @@
[iptr length]
[ptr reloc]
[ptr name]
[ptr arity-mask]
[iptr closure-length]
[ptr info]
[ptr pinfo*]

13
s/compile.ss
View File

@ -106,9 +106,9 @@
(let ([p ($make-closure (constant code-data-disp) cp)])
(set-$c-func-closure! func p)
p)))]
[(code) (func subtype free name size code-list info pinfo*)
[(code) (func subtype free name arity-mask size code-list info pinfo*)
(or ($c-func-code-object func)
(let ([p ($make-code-object subtype free name size info pinfo*)])
(let ([p ($make-code-object subtype free name arity-mask size info pinfo*)])
(set-$c-func-code-object! func p)
(let mkc0 ([c* code-list]
[a (constant code-data-disp)]
@ -240,8 +240,9 @@
($fasl-bld-graph x t a?
(lambda (x t a?)
(record-case x
[(code) (func subtype free name size code-list info pinfo*)
[(code) (func subtype free name arity-mask size code-list info pinfo*)
($fasl-enter name t a?)
($fasl-enter arity-mask t a?)
($fasl-enter info t a?)
($fasl-enter pinfo* t a?)
(for-each
@ -275,12 +276,13 @@
(define (c-faslcode x p t a?)
(record-case x
[(code) (func subtype free name size code-list info pinfo*)
[(code) (func subtype free name arity-mask size code-list info pinfo*)
(put-u8 p (constant fasl-type-code))
(put-u8 p subtype)
(put-uptr p free)
(put-uptr p size)
($fasl-out name p t a?)
($fasl-out arity-mask p t a?)
($fasl-out info p t a?)
($fasl-out pinfo* p t a?)
(let prf0 ([c* code-list]
@ -1354,13 +1356,14 @@
(build-required-library-list node* lib*))))))
(set! $c-make-code
(lambda (func subtype free name size code-list info pinfo*)
(lambda (func subtype free name arity-mask size code-list info pinfo*)
(let ([code `(code ,func
,subtype
,free
,(if (symbol? name)
(symbol->string name)
(and (string? name) name))
,arity-mask
,size
,code-list
,info

13
s/cpnanopass.ss
View File

@ -4852,6 +4852,7 @@
(inline-accessor binary-port-output-buffer port-obuffer-disp)
(inline-accessor textual-port-output-buffer port-obuffer-disp)
(inline-accessor $code-name code-name-disp)
(inline-accessor $code-arity-mask code-arity-mask-disp)
(inline-accessor $code-info code-info-disp)
(inline-accessor $code-pinfo* code-pinfo*-disp)
(inline-accessor $continuation-link continuation-link-disp)
@ -13626,7 +13627,7 @@
(lambda (funcrel)
(let* ([l (cadr funcrel)] [code ($c-func-code-record (local-label-func l))])
(record-case code
[(code) (func subtype free name size code-list info)
[(code) (func subtype free name arity-mask size code-list info)
(set-car!
funcrel
(let ([offset (local-label-offset l)])
@ -13728,6 +13729,7 @@
(info-lambda-flags info)
(length (info-lambda-fv* info))
(info-lambda-name info)
(interface*->mask (info-lambda-interface* info))
code-size
code*
(cond
@ -13815,6 +13817,15 @@
(let ([ls (cons* e1 e2 ...)])
(if aop (cons asm ls) ls))]))
(define interface*->mask
(lambda (i*)
(fold-left (lambda (mask i)
(logor mask
(if (< i 0)
(- (ash 1 (- -1 i)))
(ash 1 i))))
0 i*)))
(architecture assembler)
(import asm-module))

1
s/mkheader.ss
View File

@ -860,6 +860,7 @@
(defref CODELEN code length)
(defref CODERELOC code reloc)
(defref CODENAME code name)
(defref CODEARITYMASK code arity-mask)
(defref CODEFREE code closure-length)
(defref CODEINFO code info)
(defref CODEPINFOS code pinfo*)

2
s/primdata.ss
View File

@ -1477,6 +1477,7 @@
(pretty-format [sig [(symbol) -> (ptr)] [(symbol sub-ptr) -> (void)]] [flags])
(pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true])
(printf [sig [(string sub-ptr ...) -> (void)]] [flags true])
(procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard true])
(process [sig [(string) -> (list)]] [flags])
(profile-clear-database [sig [() -> (void)]] [flags true])
(profile-clear [sig [() -> (void)]] [flags true])
@ -1696,6 +1697,7 @@
($code? [flags])
($code-free-count [flags])
($code-info [flags])
($code-arity-mask [flags])
($code-name [flags])
($code-pinfo* [flags])
($collect-rendezvous [flags])

12
s/prims.ss
View File

@ -202,6 +202,11 @@
($oops '$procedure-name "~s is not a procedure" x))
($code-name ($closure-code x))))
(define-who procedure-arity-mask
(lambda (x)
(unless (procedure? x) ($oops who "~s is not a procedure" x))
($code-arity-mask ($closure-code x))))
(let ()
(define-syntax frob-proc
(syntax-rules ()
@ -369,7 +374,7 @@
(define-who $make-code-object
(foreign-procedure "(cs)s_make_code"
(iptr iptr ptr iptr ptr ptr)
(iptr iptr ptr ptr iptr ptr ptr)
ptr))
(define-who $code-name
@ -377,6 +382,11 @@
(unless ($code? x) ($oops who "~s is not code" x))
($code-name x)))
(define-who $code-arity-mask
(lambda (x)
(unless ($code? x) ($oops who "~s is not code" x))
($code-arity-mask x)))
(define-who $code-free-count
(lambda (x)
(unless ($code? x) ($oops who "~s is not code" x))

14
s/strip.ss
View File

@ -35,7 +35,7 @@
(large-integer sign vuptr)
(eq-hashtable mutable? weak? minlen veclen vpfasl)
(symbol-hashtable mutable? minlen equiv veclen vpfasl)
(code flags free name info pinfo* bytes m vreloc)
(code flags free name arity-mask info pinfo* bytes m vreloc)
(atom ty uptr)
(reloc type-etc code-offset item-offset fasl)
(indirect g i)
@ -244,6 +244,7 @@
[free (read-uptr p)]
[nbytes (read-uptr p)]
[name (read-fasl p g)]
[arity-mask (read-fasl p g)]
[info (read-fasl p g)]
[pinfo* (read-fasl p g)]
[bytes (let ([bv (make-bytevector nbytes)])
@ -260,7 +261,7 @@
(loop
(fx+ n (if (fxlogtest type-etc 1) 3 1))
(cons (fasl-reloc type-etc code-offset item-offset (read-fasl p g)) rls)))))])
(fasl-code flags free name info pinfo* bytes m vreloc))]
(fasl-code flags free name arity-mask info pinfo* bytes m vreloc))]
[(fasl-type-immediate fasl-type-entry fasl-type-library fasl-type-library-code)
(fasl-atom ty (read-uptr p))]
[(fasl-type-graph) (read-fasl p (make-vector (read-uptr p) #f))]
@ -429,10 +430,11 @@
(build! (car pfasl) t)
(build! (cdr pfasl) t))
vpfasl)))]
[code (flags free name info pinfo* bytes m vreloc)
[code (flags free name arity-mask info pinfo* bytes m vreloc)
(build-graph! x t
(lambda ()
(build! name t)
(build! arity-mask t)
(unless strip-inspector-information? (build! info t))
(unless strip-profile-information? (build! pinfo* t))
(vector-for-each (lambda (reloc) (build! reloc t)) vreloc)))]
@ -601,7 +603,7 @@
(write-fasl p t (car pfasl))
(write-fasl p t (cdr pfasl)))
vpfasl)))]
[code (flags free name info pinfo* bytes m vreloc)
[code (flags free name arity-mask info pinfo* bytes m vreloc)
(write-graph p t x
(lambda ()
(write-byte p (constant fasl-type-code))
@ -609,6 +611,7 @@
(write-uptr p free)
(write-uptr p (bytevector-length bytes))
(write-fasl p t name)
(write-fasl p t arity-mask)
(if strip-inspector-information?
(write-fasl p t (fasl-atom (constant fasl-type-immediate) (constant sfalse)))
(write-fasl p t info))
@ -876,10 +879,11 @@
(vandmap (lambda (x y) (and (fasl=? (car x) (car y)) (fasl=? (cdr x) (cdr y))))
(vector-sort keyval? vpfasl1)
(vector-sort keyval? vpfasl2))))]
[code (flags free name info pinfo* bytes m reloc)
[code (flags free name arity-mask info pinfo* bytes m reloc)
(and (eqv? flags1 flags2)
(eqv? free1 free2)
(fasl=? name1 name2)
(fasl=? arity-mask1 arity-mask2)
(fasl=? info1 info2)
(fasl=? pinfo*1 pinfo*2)
(bytevector=? bytes1 bytes2)