refine setup-plt output; fix profiling (PR 9356); doc string-join (PR 9401)
svn: r10021
This commit is contained in:
Matthew Flatt
parent
71268dd76e
commit
3d1241bc5d
|
|
@ -120,11 +120,11 @@
|
|||
[register-profile-done register-profile-done])
|
||||
(with-syntax ([rest
|
||||
(insert-at-tail*
|
||||
(syntax (register-profile-done 'key start))
|
||||
(syntax (#%plain-app register-profile-done 'key start))
|
||||
bodies
|
||||
trans?)])
|
||||
(syntax
|
||||
(let ([start (register-profile-start 'key)])
|
||||
(let ([start (#%plain-app register-profile-start 'key)])
|
||||
(with-continuation-mark 'profile-key 'key
|
||||
(begin . rest))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -385,4 +385,13 @@ one between @scheme[list] and @scheme[list*].
|
|||
'("Alpha" "Beta" "Gamma")))))
|
||||
]}
|
||||
|
||||
@defproc[(string-join [strs (listof string?)] [sep string?]) string?]{
|
||||
|
||||
Appends the strings in @scheme[strs], inserting @scheme[sep] between
|
||||
each pair of strings in @scheme[strs].
|
||||
|
||||
@examples[#:eval string-eval
|
||||
(string-join '("one" "two" "three" "four") " potato ")
|
||||
]}
|
||||
|
||||
@close-eval[string-eval]
|
||||
|
|
|
|||
|
|
@ -50,7 +50,8 @@
|
|||
auto-start-doc? ; if #t, expands `only-dir' with [user-]start to
|
||||
; catch new docs
|
||||
make-user? ; are we making user stuff?
|
||||
with-record-error) ; catch & record exceptions
|
||||
with-record-error ; catch & record exceptions
|
||||
setup-printf)
|
||||
(define (scribblings-flag? sym)
|
||||
(memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
|
||||
depends-all depends-all-main no-depend-on always-run)))
|
||||
|
|
@ -89,8 +90,9 @@
|
|||
(doc-path dir (cadddr d) flags)
|
||||
flags under-main? (caddr d))))
|
||||
s)
|
||||
(begin (fprintf (current-error-port)
|
||||
" bad 'scribblings info: ~e from: ~e\n" s dir)
|
||||
(begin (setup-printf
|
||||
"WARNING"
|
||||
"bad 'scribblings info: ~e from: ~e" s dir)
|
||||
null))))
|
||||
(define docs
|
||||
(let* ([dirs (find-relevant-directories '(scribblings))]
|
||||
|
|
@ -104,7 +106,7 @@
|
|||
(and (ormap can-build*? docs)
|
||||
(filter values
|
||||
(map (get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error)
|
||||
with-record-error setup-printf)
|
||||
docs))))
|
||||
(define (make-loop first? iter)
|
||||
(let ([ht (make-hash)]
|
||||
|
|
@ -115,11 +117,9 @@
|
|||
[k (info-provides info)])
|
||||
(let ([prev (hash-ref ht k #f)])
|
||||
(when (and first? prev)
|
||||
(fprintf (current-error-port)
|
||||
"DUPLICATE tag: ~s\n in: ~a\n and: ~a\n"
|
||||
k
|
||||
(doc-src-file (info-doc prev))
|
||||
(doc-src-file (info-doc info))))
|
||||
(setup-printf "WARNING" "duplicate tag: ~s" k)
|
||||
(setup-printf #f " in: ~a" (doc-src-file (info-doc prev)))
|
||||
(setup-printf #f " and: ~a" (doc-src-file (info-doc info))))
|
||||
(hash-set! ht k info)))
|
||||
;; Build deps:
|
||||
(for ([i infos])
|
||||
|
|
@ -163,12 +163,15 @@
|
|||
(hash-set! deps i #t))))
|
||||
(let ([not-found
|
||||
(lambda (k)
|
||||
(unless (or (memq 'depends-all (doc-flags (info-doc info)))
|
||||
(memq 'depends-all-main (doc-flags (info-doc info))))
|
||||
(unless one?
|
||||
(fprintf (current-error-port)
|
||||
"In ~a:\n" (path->name (doc-src-file
|
||||
(setup-printf "WARNING"
|
||||
"undefined tag in ~a:"
|
||||
(path->name (doc-src-file
|
||||
(info-doc info))))
|
||||
(set! one? #t))
|
||||
(fprintf (current-error-port) " undefined tag: ~s\n" k))])
|
||||
(setup-printf #f " ~s" k)))])
|
||||
(for ([k (info-undef info)])
|
||||
(let ([i (hash-ref ht k #f)])
|
||||
(if i
|
||||
|
|
@ -205,7 +208,7 @@
|
|||
;; Build again, using dependencies
|
||||
(for ([i infos] #:when (info-need-run? i))
|
||||
(set-info-need-run?! i #f)
|
||||
(build-again! latex-dest i with-record-error))
|
||||
(build-again! latex-dest i with-record-error setup-printf))
|
||||
;; If we only build 1, then it reaches it own fixpoint
|
||||
;; even if the info doesn't seem to converge immediately.
|
||||
;; This is a useful shortcut when re-building a single
|
||||
|
|
@ -293,7 +296,7 @@
|
|||
(fasl->s-exp (current-input-port)))
|
||||
|
||||
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?
|
||||
with-record-error)
|
||||
with-record-error setup-printf)
|
||||
doc)
|
||||
(let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")]
|
||||
[info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")]
|
||||
|
|
@ -333,9 +336,10 @@
|
|||
(memq 'depends-all-main (doc-flags doc)))
|
||||
(and auto-user?
|
||||
(memq 'depends-all (doc-flags doc)))))])
|
||||
(printf "setup-plt: ~a: ~a\n"
|
||||
(path->name (doc-src-file doc))
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"]))
|
||||
(setup-printf
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
||||
"~a"
|
||||
(path->name (doc-src-file doc)))
|
||||
(if up-to-date?
|
||||
;; Load previously calculated info:
|
||||
(with-handlers ([exn:fail? (lambda (exn)
|
||||
|
|
@ -343,7 +347,8 @@
|
|||
(delete-file info-out-file)
|
||||
(delete-file info-in-file)
|
||||
((get-doc-info only-dirs latex-dest auto-main?
|
||||
auto-user? with-record-error)
|
||||
auto-user? with-record-error
|
||||
setup-printf)
|
||||
doc))])
|
||||
(let* ([v-in (with-input-from-file info-in-file read)]
|
||||
[v-out (with-input-from-file info-out-file read-out-sxref)])
|
||||
|
|
@ -439,12 +444,13 @@
|
|||
(time expr)
|
||||
(collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use)))))
|
||||
|
||||
(define (build-again! latex-dest info with-record-error)
|
||||
(define (build-again! latex-dest info with-record-error setup-printf)
|
||||
(define doc (info-doc info))
|
||||
(define renderer (make-renderer latex-dest doc))
|
||||
(printf "setup-plt: ~a: ~arendering\n"
|
||||
(path->name (doc-src-file doc))
|
||||
(setup-printf (format "~arendering"
|
||||
(if (info-rendered? info) "re-" ""))
|
||||
"~a"
|
||||
(path->name (doc-src-file doc)))
|
||||
(set-info-rendered?! info #t)
|
||||
(with-record-error
|
||||
(doc-src-file doc)
|
||||
|
|
|
|||
|
|
@ -46,11 +46,18 @@
|
|||
launcher^)
|
||||
(export)
|
||||
|
||||
(define (setup-fprintf p s . args)
|
||||
(apply fprintf p (string-append "setup-plt: " s "\n") args))
|
||||
(define (setup-fprintf p task s . args)
|
||||
(apply fprintf p (string-append "setup-plt: "
|
||||
(if task
|
||||
(string-append
|
||||
task
|
||||
": ")
|
||||
"")
|
||||
s
|
||||
"\n") args))
|
||||
|
||||
(define (setup-printf s . args)
|
||||
(apply setup-fprintf (current-output-port) s args))
|
||||
(define (setup-printf task s . args)
|
||||
(apply setup-fprintf (current-output-port) task s args))
|
||||
|
||||
(define (exn->string x) (if (exn? x) (exn-message x) (format "~s" x)))
|
||||
|
||||
|
|
@ -72,16 +79,16 @@
|
|||
(current-library-collection-paths
|
||||
(map simplify-path (current-library-collection-paths)))
|
||||
|
||||
(setup-printf "Setup version is ~a [~a]" (version) (system-type 'gc))
|
||||
(setup-printf "Available variants:~a"
|
||||
(setup-printf "version" "~a [~a]" (version) (system-type 'gc))
|
||||
(setup-printf "variants" "~a"
|
||||
(apply string-append
|
||||
(map (lambda (s) (format " ~a" s))
|
||||
(available-mzscheme-variants))))
|
||||
(setup-printf "Main collection path is ~a" main-collects-dir)
|
||||
(setup-printf "Collection search path is~a"
|
||||
(setup-printf "main collects" "~a" (path->string main-collects-dir))
|
||||
(setup-printf "collects paths"
|
||||
(if (null? (current-library-collection-paths)) " empty!" ""))
|
||||
(for ([p (current-library-collection-paths)])
|
||||
(setup-printf " ~a" (path->string p)))
|
||||
(setup-printf #f " ~a" (path->string p)))
|
||||
|
||||
(define (call-info info flag mk-default test)
|
||||
(let ([v (info flag mk-default)]) (test v) v))
|
||||
|
|
@ -109,14 +116,14 @@
|
|||
(define (show-errors port)
|
||||
(for ([e (reverse errors)])
|
||||
(match-let ([(list cc desc x) e])
|
||||
(setup-fprintf port "Error during ~a for ~a"
|
||||
(setup-fprintf port "error" "during ~a for ~a"
|
||||
desc (if (cc? cc) (cc-name cc) cc))
|
||||
(setup-fprintf port " ~a" (exn->string x)))))
|
||||
(setup-fprintf port #f " ~a" (exn->string x)))))
|
||||
|
||||
(define (done)
|
||||
(setup-printf "Done setting up")
|
||||
(setup-printf #f "done")
|
||||
(unless (null? errors)
|
||||
(setup-printf "")
|
||||
(setup-fprintf #f "")
|
||||
(show-errors (current-error-port))
|
||||
(when (pause-on-errors)
|
||||
(fprintf (current-error-port)
|
||||
|
|
@ -135,7 +142,7 @@
|
|||
(map (lambda (x)
|
||||
(unpack x
|
||||
(build-path main-collects-dir 'up)
|
||||
(lambda (s) (setup-printf "~a" s))
|
||||
(lambda (s) (setup-printf #f "~a" s))
|
||||
(current-target-directory-getter)
|
||||
(force-unpacks)
|
||||
(current-target-plt-directory-getter)))
|
||||
|
|
@ -183,7 +190,8 @@
|
|||
(error 'make-cc*
|
||||
"Internal error: cc had invalid info-path: ~e" path))))
|
||||
(when (info 'compile-subcollections (lambda () #f))
|
||||
(setup-printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
|
||||
(setup-printf "WARNING"
|
||||
"ignoring `compile-subcollections' entry in info ~a\n"
|
||||
path-name))
|
||||
;; this check is also done in compiler/compiler-unit, in compile-directory
|
||||
(and (not (or (regexp-match? #rx"^[.]" basename) (equal? "compiled" basename)
|
||||
|
|
@ -193,7 +201,7 @@
|
|||
info root-dir info-path shadowing-policy)))
|
||||
|
||||
(define ((warning-handler v) exn)
|
||||
(setup-printf "Warning: ~a" (exn->string exn))
|
||||
(setup-printf "WARNING" "~a" (exn->string exn))
|
||||
v)
|
||||
|
||||
;; collection->cc : listof path -> cc/#f
|
||||
|
|
@ -351,7 +359,8 @@
|
|||
(for ([cc given-ccs])
|
||||
(let ([mark (cc-mark cc)])
|
||||
(when (file-exists? mark)
|
||||
(setup-printf "Warning: found a marker file, deleting: ~a"
|
||||
(setup-printf "WARNING"
|
||||
"found a marker file, deleting: ~a"
|
||||
(path->name mark))
|
||||
(delete-file mark)))))
|
||||
;; Now create all marker files, signalling an error if duplicate
|
||||
|
|
@ -479,8 +488,8 @@
|
|||
(lambda ()
|
||||
(unless printed?
|
||||
(set! printed? #t)
|
||||
(setup-printf "Deleting files for ~a at ~a"
|
||||
(cc-name cc) (path->name (cc-path cc)))))])
|
||||
(setup-printf "deleting" "in ~a"
|
||||
(path->name (cc-path cc)))))])
|
||||
(for ([path paths])
|
||||
(let ([full-path (build-path (cc-path cc) path)])
|
||||
(when (or (file-exists? full-path) (directory-exists? full-path))
|
||||
|
|
@ -517,7 +526,7 @@
|
|||
;; delete .zos for referenced modules and delete
|
||||
;; info-domain cache
|
||||
(when no-specific-collections?
|
||||
(setup-printf "Checking dependencies")
|
||||
(setup-printf #f "checking dependencies")
|
||||
(let loop ([old-dependencies dependencies])
|
||||
(let ([dependencies (make-hash)]
|
||||
[did-something? #f])
|
||||
|
|
@ -533,7 +542,7 @@
|
|||
(delete-file/record-dependency zo dependencies)
|
||||
(delete-file/record-dependency dep dependencies))))))
|
||||
(when did-something? (loop dependencies))))
|
||||
(setup-printf "Clearing info-domain caches")
|
||||
(setup-printf #f "clearing info-domain caches")
|
||||
(for ([p (current-library-collection-paths)])
|
||||
(let ([fn (build-path p "info-domain" "compiled" "cache.ss")])
|
||||
(when (file-exists? fn)
|
||||
|
|
@ -575,8 +584,9 @@
|
|||
[(pre) 'pre-installer]
|
||||
[(general) 'installer]
|
||||
[(post) 'post-installer])))])
|
||||
(setup-printf "~aInstalling ~a"
|
||||
(case part [(pre) "Pre-"] [(post) "Post-"] [else ""])
|
||||
(setup-printf (format "~ainstalling"
|
||||
(case part [(pre) "pre-"] [(post) "post-"] [else ""]))
|
||||
"~a"
|
||||
(cc-name cc))
|
||||
(let ([dir (build-path main-collects-dir 'up)])
|
||||
(if (procedure-arity-includes? installer 2)
|
||||
|
|
@ -591,23 +601,27 @@
|
|||
;; To avoid keeping modules in memory across collections, pass
|
||||
;; `make-base-namespace' as `get-namespace', otherwise use
|
||||
;; `current-namespace' for `get-namespace'.
|
||||
(let ([gc? #f])
|
||||
(for ([cc ccs-to-compile])
|
||||
(parameterize ([current-namespace (get-namespace)])
|
||||
(begin-record-error cc (format "~a: compiling..." desc)
|
||||
(begin-record-error
|
||||
cc (format "~a: compiling..." desc)
|
||||
(unless (control-io-apply
|
||||
(case-lambda
|
||||
[(p)
|
||||
;; Main "doing something" message
|
||||
(setup-fprintf p "~a: compiling ~a" (cc-name cc) desc)]
|
||||
(set! gc? #t)
|
||||
(setup-fprintf p "making" "~a" (cc-name cc))]
|
||||
[(p where)
|
||||
;; Doing something specifically in "where"
|
||||
(setup-fprintf p " in ~a"
|
||||
(setup-fprintf p #f " in ~a"
|
||||
(path->name (path->complete-path
|
||||
where (cc-path cc))))])
|
||||
compile-directory
|
||||
(list (cc-path cc) (cc-info cc)))
|
||||
(setup-printf "~a: all ~a done" (cc-name cc) desc))))
|
||||
(collect-garbage)))
|
||||
(setup-printf "making" "~a" (cc-name cc)))))
|
||||
(when gc?
|
||||
(collect-garbage)))))
|
||||
|
||||
(define (with-specified-mode thunk)
|
||||
(if (not (compile-mode))
|
||||
|
|
@ -658,7 +672,7 @@
|
|||
(for ([p (directory-list c)])
|
||||
(when (and (regexp-match #rx#".zo$" (path-element->bytes p))
|
||||
(not (hash-ref ok-zo-files p #f)))
|
||||
(setup-fprintf (current-error-port) " deleting ~a" (build-path c p))
|
||||
(setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
|
||||
(delete-file (build-path c p))))))))
|
||||
;; Make .zos
|
||||
(compile-directory-zos dir info))
|
||||
|
|
@ -752,7 +766,7 @@
|
|||
info-path))
|
||||
(make-directory* base)
|
||||
(let ([p info-path])
|
||||
(setup-printf "Updating ~a" (path->name p))
|
||||
(setup-printf "updating" "~a" (path->name p))
|
||||
(with-handlers ([exn:fail? (warning-handler (void))])
|
||||
(with-output-to-file p
|
||||
#:exists 'truncate/replace
|
||||
|
|
@ -777,17 +791,18 @@
|
|||
(dynamic-require 'setup/scribble 'setup-scribblings)))
|
||||
|
||||
(when (make-docs)
|
||||
(setup-printf "Building documentation")
|
||||
(setup-printf #f "building documentation")
|
||||
((doc:verbose) (verbose))
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(setup-printf "Docs failure: ~a" (exn->string exn)))])
|
||||
(setup-printf #f "docs failure: ~a" (exn->string exn)))])
|
||||
((doc:setup-scribblings)
|
||||
(if no-specific-collections? #f (map cc-path ccs-to-compile))
|
||||
#f
|
||||
(not (null? (archives)))
|
||||
(make-user)
|
||||
(lambda (what go alt) (record-error what "Building docs" go alt)))))
|
||||
(lambda (what go alt) (record-error what "Building docs" go alt))
|
||||
setup-printf)))
|
||||
|
||||
(define (render-pdf file)
|
||||
(define cmd
|
||||
|
|
@ -797,8 +812,8 @@
|
|||
(when (= n 5)
|
||||
(error 'render-pdf "didn't get a stable result after ~a runs" n))
|
||||
(if (zero? n)
|
||||
(setup-printf "running pdflatex on ~a" file)
|
||||
(setup-printf " re-running ~a~a time"
|
||||
(setup-printf "running" "pdflatex on ~a" file)
|
||||
(setup-printf #f " re-running ~a~a time"
|
||||
(add1 n) (case (add1 n) [(2) 'nd] [(3) 'rd] [else 'th])))
|
||||
(unless (system cmd)
|
||||
(call-with-input-file logfile
|
||||
|
|
@ -812,12 +827,13 @@
|
|||
(lambda (log) (regexp-match? #px#"changed\\.\\s+Rerun" log)))
|
||||
(loop (add1 n))]
|
||||
[(zero? n)
|
||||
(setup-printf "Warning: no \"Rerun\" found in first run of pdflatex for ~a"
|
||||
(setup-printf "WARNING"
|
||||
"no \"Rerun\" found in first run of pdflatex for ~a"
|
||||
file)]))
|
||||
(path-replace-suffix file #".pdf"))
|
||||
|
||||
(when (doc-pdf-dest)
|
||||
(setup-printf "Building PDF documentation (via pdflatex)")
|
||||
(setup-printf #f "building PDF documentation (via pdflatex)")
|
||||
(let ([dest-dir (path->complete-path (doc-pdf-dest))])
|
||||
(unless (directory-exists? dest-dir)
|
||||
(make-directory dest-dir))
|
||||
|
|
@ -880,7 +896,8 @@
|
|||
[(not (or mzlls mzlfs))
|
||||
(unless (null? mzlns)
|
||||
(setup-printf
|
||||
"Warning: ~a launcher name list ~s has no matching library/flags lists"
|
||||
"WARNING"
|
||||
"~a launcher name list ~s has no matching library/flags lists"
|
||||
kind mzlns))]
|
||||
[(and (or (not mzlls) (= (length mzlns) (length mzlls)))
|
||||
(or (not mzlfs) (= (length mzlns) (length mzlfs))))
|
||||
|
|
@ -895,12 +912,13 @@
|
|||
(build-path (cc-path cc)
|
||||
(path-replace-suffix (or mzll mzln) #""))))])
|
||||
(unless (up-to-date? p aux)
|
||||
(setup-printf "Installing ~a~a launcher ~a"
|
||||
(setup-printf "launcher"
|
||||
"~a [~a~a]"
|
||||
(path->string p)
|
||||
kind (let ([v (current-launcher-variant)])
|
||||
(if (eq? v (system-type 'gc))
|
||||
""
|
||||
(format " ~a" v)))
|
||||
(path->string p))
|
||||
(format " ~a" v))))
|
||||
(make-launcher
|
||||
(or mzlf
|
||||
(if (cc-collection cc)
|
||||
|
|
@ -923,7 +941,8 @@
|
|||
[else
|
||||
(let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)])
|
||||
(setup-printf
|
||||
"Warning: ~a launcher name list ~s doesn't match ~a list; ~s"
|
||||
"WARNING"
|
||||
"~a launcher name list ~s doesn't match ~a list; ~s"
|
||||
kind mzlns
|
||||
(if (eq? 'l fault) "library" "flags")
|
||||
(if (eq? fault 'l) mzlls mzlfs)))]))
|
||||
|
|
|
|||
|
|
@ -2582,7 +2582,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
|
|||
if (!genv) {
|
||||
scheme_wrong_syntax("require", NULL, src_find_id,
|
||||
"namespace mismatch; reference (phase %d) to a module"
|
||||
" %D that is not available (phase %d)",
|
||||
" %D that is not available (phase level %d)",
|
||||
env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase));
|
||||
return NULL;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1796,7 +1796,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
|
|||
if (!menv) {
|
||||
scheme_wrong_syntax("link", NULL, varname,
|
||||
"namespace mismatch; reference (phase %d) to a module"
|
||||
" %D that is not available (phase %d); reference"
|
||||
" %D that is not available (phase level %d); reference"
|
||||
" appears in module: %D",
|
||||
env->phase,
|
||||
modname,
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user