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

add option to omit RTD descriptions in fasl output

Browse Source 
original commit: 294ca9da084d76aa7b649059856066a1f86fe21b
This commit is contained in:
Matthew Flatt 2020-07-14 18:01:57 -06:00
parent ec05bac0cf
commit b8c1ce63c6
7 changed files with 81 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
c/fasl.c
View File

@ -229,7 +229,7 @@ static float singlein PROTO((faslFile f));
static double doublein PROTO((faslFile f));
static iptr stringin PROTO((ptr *pstrbuf, iptr start, faslFile f));
static void faslin PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f));
static void fasl_record PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f));
static void fasl_record PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size));
static IBOOL rtd_equiv PROTO((ptr x, ptr y));
static IBOOL equalp PROTO((ptr x, ptr y));
#ifdef ARMV6
@ -803,7 +803,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
*x = rtd;
return;
} case fasl_type_rtd: {
ptr rtd, rtd_uid, plist, ls;
ptr rtd, rtd_uid, plist, ls; uptr size;
faslin(tc, &rtd_uid, t, pstrbuf, f);
@ -813,14 +813,21 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
if (Scar(ls) == S_G.rtd_key) {
ptr tmp;
*x = rtd = Scar(Scdr(ls));
fasl_record(tc, &tmp, t, pstrbuf, f);
if (!rtd_equiv(tmp, rtd))
S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(tmp), f->uf->path);
size = uptrin(f);
if (size != 0) {
fasl_record(tc, &tmp, t, pstrbuf, f, size);
if (!rtd_equiv(tmp, rtd))
S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(tmp), f->uf->path);
}
return;
}
}
fasl_record(tc, x, t, pstrbuf, f);
size = uptrin(f);
if (size == 0)
S_error2("", "unregistered record type ~s in ~a", rtd_uid, f->uf->path);
fasl_record(tc, x, t, pstrbuf, f, size);
rtd = *x;
/* register rtd on uid's property list */
@ -828,7 +835,8 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
return;
}
case fasl_type_record: {
fasl_record(tc, x, t, pstrbuf, f);
uptr size = uptrin(f);
fasl_record(tc, x, t, pstrbuf, f, size);
return;
}
case fasl_type_eq_hashtable: {
@ -1087,10 +1095,9 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
#define big 0
#define little 1
static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
uptr size, n, addr; ptr p; UINT padty;
static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size) {
uptr n, addr; ptr p; UINT padty;
size = uptrin(f);
n = uptrin(f);
*x = p = S_record(size_record_inst(size));
faslin(tc, &RECORDINSTTYPE(p), t, pstrbuf, f);

7
csug/io.stex
View File

@ -3379,7 +3379,7 @@ input port, must be used instead.
%----------------------------------------------------------------------------
\entryheader
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port})}
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port} \var{external-pred})}
\formdef{fasl-write}{\categoryprocedure}{(fasl-write \var{obj} \var{binary-output-port} \var{external-pred} \var{omit-rtds?})}
\returns unspecified
\listlibraries
\endentryheader
@ -3405,6 +3405,11 @@ through its closure. When the fasl representation is read with
must be provided, and each placeholder is replaced with the
corresponding vector element.
If \var{omit-rtds?} is present and true, then any record types
relevant to \var{obj} must be declared in the loading context, and the
loading context is assumed to have compatible record-type
registrations using the same unique ID.
The fasl representation of \var{obj} is compressed if the parameter
\scheme{fasl-compressed}, described below, is set to \scheme{#t},
its default value.

6
csug/system.stex
View File

@ -1527,6 +1527,7 @@ will take care of closing the ports.
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port})}
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop})}
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop} \var{external-pred})}
\formdef{compile-to-port}{\categoryprocedure}{(compile-to-port \var{obj-list} \var{output-port} \var{sfd} \var{wpo-port} \var{covop} \var{external-pred} \var{omit-rtds?})}
\returns see below
\listlibraries
\endentryheader
@ -1564,6 +1565,11 @@ corresponding vector must be provided to
\scheme{load-compiled-from-port} to load the compiled code, analogous
to the vector supplied to \scheme{fasl-read}.
If \var{omit-rtds?} is present and true, then any record types
relevant to the compiled code must be declared in the loading context,
and the loading context is assumed to have compatible registrations
using the same unique ID.
When \var{obj-list} contains a single list-structured element whose
first-element is the symbol \scheme{top-level-program},
\scheme{compile-to-port} returns a list of the libraries the top-level

2
s/cmacros.ss
View File

@ -1683,6 +1683,8 @@
(define-constant annotation-profile #b0010)
(define-constant annotation-all #b0011)
(define-constant fasl-omit-rtds #b0100)
(eval-when (compile load eval)
(define flag->mask
(lambda (m e)

48
s/compile.ss
View File

@ -457,11 +457,12 @@
[else (c-assembler-output-error c)])]))))))]
[else (c-assembler-output-error x)])))
(define (c-print-fasl x p situation external?-pred)
(define (c-print-fasl x p situation external?-pred omit-rtds?)
(let ([t ($fasl-table external?-pred)]
[a? (let ([flags (fxlogor
(if (generate-inspector-information) (constant annotation-debug) 0)
(if (eq? ($compile-profile) 'source) (constant annotation-profile) 0))])
(if (eq? ($compile-profile) 'source) (constant annotation-profile) 0)
(if omit-rtds? (constant fasl-omit-rtds) 0))])
(and (not (fx= flags 0)) flags))])
(c-build-fasl x t a?)
($fasl-start p t situation
@ -520,7 +521,7 @@
x)))
(define compile-file-help
(lambda (op hostop wpoop source-table machine sfd do-read outfn external?-pred)
(lambda (op hostop wpoop source-table machine sfd do-read outfn external?-pred omit-rtds?)
(parameterize ([$target-machine machine]
[$sfd sfd]
[$current-mso ($current-mso)]
@ -548,7 +549,7 @@
(let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()])
(let ([x0 ($pass-time 'read do-read)])
(if (eof-object? x0)
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) external?-pred)
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) external?-pred omit-rtds?)
(let ()
(define source-info-string
(and (or ($assembly-output) (expand-output) (expand/optimize-output))
@ -748,7 +749,7 @@
[else (finish-compile x1 values)]))))))
(define compile-file-help2
(lambda (op rcinfo** lpinfo** final** external?-pred)
(lambda (op rcinfo** lpinfo** final** external?-pred omit-rtds?)
(define (libreq-hash x) (symbol-hash (libreq-uid x)))
(define (libreq=? x y) (eq? (libreq-uid x) (libreq-uid y)))
(let ([import-ht (make-hashtable libreq-hash libreq=?)]
@ -771,15 +772,15 @@
($pass-time 'pfasl
(lambda ()
(unless (and (compile-omit-concatenate-support) (null? import-req*) (null? include-req*))
(c-print-fasl `(object ,(make-recompile-info import-req* include-req*)) op (constant fasl-type-visit-revisit) #f))
(c-print-fasl `(object ,(make-recompile-info import-req* include-req*)) op (constant fasl-type-visit-revisit) #f #f))
(for-each
(lambda (final*)
(for-each
(lambda (x)
(record-case x
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit) external?-pred)]
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit) external?-pred)]
[else (c-print-fasl x op (constant fasl-type-visit-revisit) external?-pred)]))
[(visit-stuff) x (c-print-fasl x op (constant fasl-type-visit) external?-pred omit-rtds?)]
[(revisit-stuff) x (c-print-fasl x op (constant fasl-type-revisit) external?-pred omit-rtds?)]
[else (c-print-fasl x op (constant fasl-type-visit-revisit) external?-pred omit-rtds?)]))
final*))
(append lpinfo**
(if (compile-omit-concatenate-support)
@ -858,7 +859,7 @@
(emit-header op (constant scheme-version) (constant machine-type))
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
(if (null? x1*)
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) #f)
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**) #f #f)
(let-values ([(rcinfo* lpinfo* final*)
(let ([x1 (car x1*)])
(if (recompile-info? x1)
@ -1566,7 +1567,7 @@
(when source-table ($insert-profile-src! source-table x1))
(emit-header op (constant scheme-version) (constant machine-type))
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)])
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*) #f)))))))))
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*) #f #f)))))))))
(define write-wpo-file
(lambda (who ofn ir*)
@ -1718,8 +1719,8 @@
(emit-header op (constant scheme-version) (constant machine-type) (map path-root (map path-last bootfiles)))
(when (null? bootfiles)
(parameterize ([$target-machine machine] [$sfd #f])
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit) #f)
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit) #f)
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit) #f #f)
(c-print-fasl ($np-boot-code 'invoke) op (constant fasl-type-visit-revisit) #f #f)
($fasl-base-rtd #!base-rtd op)))))
(define do-make-boot-file
@ -1763,7 +1764,7 @@
(let ([sfd ($source-file-descriptor infn ip)])
; whack ip so close-port calls close the text port
(set! ip (transcoded-port ip (current-transcoder)))
(compile-file-help op #f #f source-table machine sfd ($make-read ip sfd 0) outfn #f))))
(compile-file-help op #f #f source-table machine sfd ($make-read ip sfd 0) outfn #f #f))))
(close-port ip)))
infn*)))))))
@ -1894,7 +1895,7 @@
(c-print-fasl `(object ,(make-recompile-info
(vector->list (hashtable-keys import-ht))
(vector->list (hashtable-keys include-ht))))
op (constant fasl-type-visit-revisit) #f)
op (constant fasl-type-visit-revisit) #f #f)
(for-each (lambda (ip)
(let loop () ;; NB: This loop consumes one entry past the last library/program info record,
;; which we presume is the #t end-of-header marker.
@ -1903,11 +1904,11 @@
;; perhaps should verify ty here.
(let ([x (fasl-read ip)])
(when (or (library-info? x) (program-info? x))
(c-print-fasl `(object ,x) op ty #f)
(c-print-fasl `(object ,x) op ty #f #f)
(loop)))))))
ip*)
;; inserting #t after lpinfo as an end-of-header marker
(c-print-fasl `(object #t) op (constant fasl-type-visit-revisit) #f)
(c-print-fasl `(object #t) op (constant fasl-type-visit-revisit) #f #f)
(let* ([bufsiz (file-buffer-size)] [buf (make-bytevector bufsiz)])
(for-each (lambda (ip)
(let loop ()
@ -1977,7 +1978,7 @@
(if ($port-flags-set? ip (constant port-flag-char-positions))
fp
(and (eqv? fp 0) fp))))])
(compile-file-help op hostop wpoop source-table machine sfd ($make-read ip sfd fp) #f #f)
(compile-file-help op hostop wpoop source-table machine sfd ($make-read ip sfd fp) #f #f #f)
(when covop (put-source-table covop source-table))))])))
(set-who! compile-to-port
@ -1989,7 +1990,8 @@
[(sexpr* op sfd wpoop covop) (compile-to-port sexpr* op sfd wpoop covop (constant machine-type-name))]
[(sexpr* op sfd wpoop covop machine) (compile-to-port sexpr* op sfd wpoop covop machine #f)]
[(sexpr* op sfd wpoop covop machine hostop) (compile-to-port sexpr* op sfd wpoop covop machine hostop #f)]
[(sexpr* op sfd wpoop covop machine hostop external?-pred)
[(sexpr* op sfd wpoop covop machine hostop external?-pred) (compile-to-port sexpr* op sfd wpoop covop machine hostop external?-pred #f)]
[(sexpr* op sfd wpoop covop machine hostop external?-pred omit-rtds?)
(define do-compile-to-port
(lambda ()
(let ([source-table (and covop (make-source-table))])
@ -2001,7 +2003,7 @@
(set! sexpr* (cdr sexpr*))
x)))
(port-name op)
external?-pred)
external?-pred omit-rtds?)
(when covop (put-source-table covop source-table)))))
(unless (list? sexpr*)
($oops who "~s is not a proper list" sexpr*))
@ -2054,7 +2056,7 @@
(lambda (wpoop)
(with-coverage-file who out
(lambda (source-table)
(compile-file-help op hostop wpoop source-table machine sfd do-read out #f))))))))))
(compile-file-help op hostop wpoop source-table machine sfd do-read out #f #f))))))))))
(define (do-compile-file who in out hostout machine r6rs?)
(unless (string? in) ($oops who "~s is not a string" in))
@ -2134,7 +2136,7 @@
(when wpoop (put-u8 wpoop n)))
(let ([fp (+ fp 1)])
(if (char=? c #\newline) fp (loop fp)))))])
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out #f))))))))
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out #f #f))))))))
; no #! line
(with-object-file who out
(lambda (op)
@ -2143,7 +2145,7 @@
(lambda (wpoop)
(with-coverage-file who out
(lambda (source-table)
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd 0) out #f)))))))))))
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd 0) out #f #f)))))))))))
(close-port ip))
(unless-feature windows (chmod out #o755)))

37
s/fasl.ss
View File

@ -491,7 +491,9 @@
[(record-type-descriptor? x)
(put-u8 p (constant fasl-type-rtd))
(wrf (record-type-uid x) p t a?)
(wrf-fields (maybe-remake-rtd x) p t a?)]
(if (and a? (fxlogtest a? (constant fasl-omit-rtds)))
(put-uptr p 0) ; => must be registered already at load time
(wrf-fields (maybe-remake-rtd x) p t a?))]
[else
(put-u8 p (constant fasl-type-record))
(wrf-fields x p t a?)])))
@ -500,9 +502,10 @@
(lambda (x p t a?)
(define maybe-remake-annotation
(lambda (x a?)
(if (fx= (annotation-flags x) a?)
x
(make-annotation (annotation-expression x) (annotation-source x) (annotation-stripped x) a?))))
(let ([a? (fxand a? (constant annotation-all))])
(if (fx= (annotation-flags x) a?)
x
(make-annotation (annotation-expression x) (annotation-source x) (annotation-stripped x) a?)))))
(put-u8 p (constant fasl-type-record))
(wrf-fields (maybe-remake-annotation x a?) p t a?)))
)
@ -629,7 +632,7 @@
[(bytevector? x) (wrf-graph x p t a? wrf-bytevector)]
; this check must go before $record? check
[(annotation? x)
(if a?
(if (and a? (fxlogtest a? (constant annotation-all)))
(wrf-graph x p t a? wrf-annotation)
(wrf (annotation-stripped x) p t a?))]
; this check must go before $record? check
@ -708,22 +711,27 @@
; when called from fasl-write or fasl-file, always preserve annotations;
; otherwise use value passed in by the compiler
(define fasl-one
(lambda (x p external?-pred)
(let ([t (make-table external?-pred)])
(bld x t (constant annotation-all) 0)
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t (constant annotation-all)))))))
(lambda (x p external?-pred omit-rtds?)
(let ([t (make-table external?-pred)]
[a? (fxior (constant annotation-all)
(if omit-rtds?
(constant fasl-omit-rtds)
0))])
(bld x t a? 0)
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t a?))))))
(define-who fasl-write
(case-lambda
[(x p) (fasl-write x p #f)]
[(x p external?-pred)
[(x p) (fasl-write x p #f #f)]
[(x p external?-pred) (fasl-write x p external?-pred #f)]
[(x p external?-pred omit-rtds?)
(unless (and (output-port? p) (binary-port? p))
($oops who "~s is not a binary output port" p))
(unless (or (not external?-pred) (procedure? external?-pred))
($oops who "~s is not #f or a procedure" external?-pred))
(when ($port-flags-set? p (constant port-flag-compressed)) ($compressed-warning who p))
(emit-header p (constant scheme-version) (constant machine-type-any))
(fasl-one x p external?-pred)]))
(fasl-one x p external?-pred omit-rtds?)]))
(define-who fasl-file
(lambda (in out)
@ -742,7 +750,7 @@
(let fasl-loop ()
(let ([x (read ip)])
(unless (eof-object? x)
(fasl-one x op #f)
(fasl-one x op #f #f)
(fasl-loop)))))
(close-port op))
(close-port ip)))))
@ -774,7 +782,8 @@
(set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))
(set! fasl-write (case-lambda
[(x p) ((target-fasl-write (fasl-target)) x p)]
[(x p externals) ((target-fasl-write (fasl-target)) x p externals)]))
[(x p externals) ((target-fasl-write (fasl-target)) x p externals)]
[(x p externals omit-rtds?) ((target-fasl-write (fasl-target)) x p externals omit-rtds?)]))
(set! fasl-file (lambda (in out) ((target-fasl-file (fasl-target)) in out))))
(when ($unbound-object? (#%$top-level-value '$capture-fasl-target))

4
s/primdata.ss
View File

@ -1237,7 +1237,7 @@
(compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard])
(compile-to-file [sig [(list pathname) (list pathname maybe-sfd) -> (void/list)]] [flags true])
(compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr) -> (void/list)]] [flags true])
(compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr ptr) -> (void/list)]] [flags true])
(compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags])
(compile-whole-library [sig [(string string) -> (void)]] [flags])
(compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc])
@ -1310,7 +1310,7 @@
(expt-mod [sig [(integer integer integer) -> (integer)]] [flags arith-op mifoldable discard])
(fasl-file [sig [(pathname pathname) -> (void)]] [flags true])
(fasl-read [sig [(binary-input-port) (binary-input-port sub-symbol) (binary-input-port sub-symbol vector) -> (ptr)]] [flags])
(fasl-write [sig [(sub-ptr binary-output-port) (sub-ptr binary-output-port ptr) -> (void)]] [flags true])
(fasl-write [sig [(sub-ptr binary-output-port) (sub-ptr binary-output-port ptr) (sub-ptr binary-output-port ptr ptr) -> (void)]] [flags true])
(vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags])
(file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])
(file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard])