From 7401674892d10adb0259c3ea494af3b8e03b88a1 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 23 Jun 2023 15:28:30 +0200 Subject: [PATCH 6/6] Don't override ##sys#default-read-info-hook to read with source info Overriding this hook with fluid-let to add line number tracking has a few problems: - Calling (read) in csi or on other repls would cause all forms to get added to the line number database, even if just reading a data file. Even though it's not a huge problem memory-wise due to the forms being weakly held in the database, it could still be rather slow if a lot of data is read due to the scanning of broken weak pointers. - If you use (chicken repl) in a threaded program, all (read) calls of the program would (unintentionally) use the line number db. To fix this, change the code in csi as well as (load), (repl) and (##sys#include-forms-from-file) to use ##sys#read/source-info instead of scheme#read and fluid-letting ##sys#default-read-info-hook to the line number tracking version. NOTE: We could drop ##sys#default-read-info-hook entirely, but that would break user code that uses it, like the r7rs egg, so keep it for now. --- core.scm | 23 ++++++++--------- csi.scm | 7 +++--- eval.scm | 16 ++++++------ expand.scm | 11 +++++--- repl.scm | 74 +++++++++++++++++++++++++----------------------------- 5 files changed, 63 insertions(+), 68 deletions(-) diff --git a/core.scm b/core.scm index 0d1a5c88..bf8ada8e 100644 --- a/core.scm +++ b/core.scm @@ -990,18 +990,17 @@ bs) ) ) ) ) ((##core#include) - (fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook)) - (##sys#include-forms-from-file - (cadr x) - (caddr x) - (lambda (forms) - (walk (if (pair? (cdddr x)) ; body? - (canonicalize-body/ln - ln - (append forms (cadddr x)) - compiler-syntax-enabled) - `(##core#begin ,@forms)) - e dest ldest h ln tl?))))) + (##sys#include-forms-from-file + (cadr x) + (caddr x) + (lambda (forms) + (walk (if (pair? (cdddr x)) ; body? + (canonicalize-body/ln + ln + (append forms (cadddr x)) + compiler-syntax-enabled) + `(##core#begin ,@forms)) + e dest ldest h ln tl?)))) ((##core#let-module-alias) (##sys#with-module-aliases diff --git a/csi.scm b/csi.scm index e4a865d2..fca1da4e 100644 --- a/csi.scm +++ b/csi.scm @@ -280,7 +280,7 @@ EOF (define default-evaluator (let ((eval eval) (load-noisily load-noisily) - (read read) + (read (lambda () (##sys#read/source-info (current-input-port)))) (read-line read-line) (display display) (string-split string-split) @@ -1047,7 +1047,7 @@ EOF (load home-fn) ) ) ) ) (define (evalstring str #!optional (rec (lambda _ (void)))) (let ((in (open-input-string str))) - (do ([x (read in) (read in)]) + (do ([x (##sys#read/source-info in) (##sys#read/source-info in)]) ((eof-object? x)) (rec (receive (eval x))) ) ) ) (when (member* '("-h" "-help" "--help") args) @@ -1157,5 +1157,4 @@ EOF (let ((r (optional rs))) (exit (if (fixnum? r) r 0))))))))))))) -(fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook)) - (run))) +(run)) diff --git a/eval.scm b/eval.scm index 18f496ed..9a69e051 100644 --- a/eval.scm +++ b/eval.scm @@ -1024,8 +1024,7 @@ (##sys#make-c-string (##sys#string-append "C_" (toplevel name)) loc)) (define load/internal - (let ((read read) - (write write) + (let ((write write) (display display) (newline newline) (eval eval) @@ -1089,8 +1088,8 @@ "unable to load compiled module - " (or _dlerror "unknown reason")) fname))) - (let ((x1 (read in))) - (do ((x x1 (read in))) + (let ((x1 (##sys#read/source-info in))) + (do ((x x1 (##sys#read/source-info in))) ((eof-object? x)) (when printer (printer x)) (##sys#call-with-values @@ -1163,8 +1162,7 @@ (load-unit unit-name lib 'load-library)) (define ##sys#include-forms-from-file - (let ((with-input-from-file with-input-from-file) - (read read) + (let ((call-with-input-file call-with-input-file) (reverse reverse)) (lambda (filename source k) (let ((path (##sys#resolve-include-filename filename #t #f source))) @@ -1172,10 +1170,10 @@ (##sys#signal-hook #:file-error 'include "cannot open file" filename)) (when (load-verbose) (print "; including " path " ...")) - (with-input-from-file path - (lambda () + (call-with-input-file path + (lambda (in) (fluid-let ((##sys#current-source-filename path)) - (do ((x (read) (read)) + (do ((x (##sys#read/source-info in) (##sys#read/source-info in)) (xs '() (cons x xs))) ((eof-object? x) (k (reverse xs))))))))))) diff --git a/expand.scm b/expand.scm index adcb737d..b1c82113 100644 --- a/expand.scm +++ b/expand.scm @@ -732,7 +732,7 @@ (lp (cdr lst) prev)) (else (lp (cdr lst) lst))))) -(define (##sys#read/source-info-hook class data val) ; Used here, in core.scm and in csi.scm +(define (read/source-info-hook class data val) (when (and (eq? 'list-info class) (symbol? (car data))) (let ((old-value (or (hash-table-ref ##sys#line-number-database (car data)) '()))) (assq/drop-bwp! (car data) old-value) ;; Hack to clean out garbage values @@ -744,9 +744,14 @@ old-value ) )) ) data) +(define-constant line-number-database-size 997) ; Copied from core.scm + ;; TODO: Should we export this, or something like it? -(define (##sys#read/source-info in) ; Used only in batch-driver - (##sys#read in ##sys#read/source-info-hook) ) +(define (##sys#read/source-info in) + ;; Initialize line number db on first use + (unless ##sys#line-number-database + (set! ##sys#line-number-database (make-vector line-number-database-size '()))) + (##sys#read in read/source-info-hook) ) (define (get-line-number sexp) diff --git a/repl.scm b/repl.scm index 87f26cf0..523ddd34 100644 --- a/repl.scm +++ b/repl.scm @@ -40,8 +40,6 @@ (include "common-declarations.scm") -(define-constant line-number-database-size 997) ; Copied from core.scm - (define ##sys#repl-print-length-limit #f) (define ##sys#repl-read-hook #f) (define ##sys#repl-recent-call-chain #f) ; used in csi for ,c command @@ -71,7 +69,6 @@ (define repl (let ((eval eval) - (read read) (call-with-current-continuation call-with-current-continuation) (string-append string-append)) (lambda (#!optional (evaluator eval)) @@ -117,9 +114,6 @@ (set! quit-hook (lambda (result) (k result))) (load-verbose #t) (set! ##sys#notices-enabled #t) - ;; Make sure line number db is initialized but don't clear it if (repl) is called again - (unless ##sys#line-number-database - (set! ##sys#line-number-database (make-vector line-number-database-size '()))) (##sys#error-handler (lambda (msg . args) (resetports) @@ -156,40 +150,40 @@ (resetports) (c #f))))) (##sys#read-prompt-hook) - (fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook)) - (let ((exp ((or ##sys#repl-read-hook read)))) - (unless (eof-object? exp) - (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input)) - (##sys#read-char-0 ##sys#standard-input)) - (foreign-code "C_clear_trace_buffer();") - (set! ##sys#unbound-in-eval '()) - (receive result (evaluator exp) - (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval)) - (let loop ((vars ##sys#unbound-in-eval) - (u '())) - (cond ((null? vars) - (when (pair? u) - (when ##sys#notices-enabled - (##sys#notice - "the following toplevel variables are referenced but unbound:\n") - (for-each - (lambda (v) - (##sys#print " " #f ##sys#standard-error) - (##sys#print (car v) #t ##sys#standard-error) - (when (cdr v) - (##sys#print " (in " #f ##sys#standard-error) - (##sys#print (cdr v) #t ##sys#standard-error) - (##sys#write-char-0 #\) ##sys#standard-error)) - (##sys#write-char-0 #\newline ##sys#standard-error)) - u) - (##sys#flush-output ##sys#standard-error)))) - ((or (memq (caar vars) u) - (##core#inline "C_u_i_namespaced_symbolp" (caar vars)) - (##sys#symbol-has-toplevel-binding? (caar vars))) - (loop (cdr vars) u)) - (else (loop (cdr vars) (cons (car vars) u)))) 9)) - (write-results result) - (loop))))))) + (let* ((read (lambda () (##sys#read/source-info ##sys#standard-input))) + (exp ((or ##sys#repl-read-hook read)))) + (unless (eof-object? exp) + (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input)) + (##sys#read-char-0 ##sys#standard-input)) + (foreign-code "C_clear_trace_buffer();") + (set! ##sys#unbound-in-eval '()) + (receive result (evaluator exp) + (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval)) + (let loop ((vars ##sys#unbound-in-eval) + (u '())) + (cond ((null? vars) + (when (pair? u) + (when ##sys#notices-enabled + (##sys#notice + "the following toplevel variables are referenced but unbound:\n") + (for-each + (lambda (v) + (##sys#print " " #f ##sys#standard-error) + (##sys#print (car v) #t ##sys#standard-error) + (when (cdr v) + (##sys#print " (in " #f ##sys#standard-error) + (##sys#print (cdr v) #t ##sys#standard-error) + (##sys#write-char-0 #\) ##sys#standard-error)) + (##sys#write-char-0 #\newline ##sys#standard-error)) + u) + (##sys#flush-output ##sys#standard-error)))) + ((or (memq (caar vars) u) + (##core#inline "C_u_i_namespaced_symbolp" (caar vars)) + (##sys#symbol-has-toplevel-binding? (caar vars))) + (loop (cdr vars) u)) + (else (loop (cdr vars) (cons (car vars) u)))) 9)) + (write-results result) + (loop)))))) (lambda () (load-verbose lv) (set! quit-hook qh) -- 2.40.1