From 3dce81345d11a41ff9a494053e2586cc4bb89936 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 13 Jul 2022 12:51:54 +0200 Subject: Comment out typechecks on token stream. Each such typecheck ran in linear time on the remaining tokens, which is a bit to much. Remove it, and hope that the code behaves. Some stats, from running make coverage GUILE=guile3 With typechecks --------------- Slow test: "Parameter expansion times", took 1.077431 Slow test: "Example 3, except part below", took 16.952855 Slow test: "True test", took 18.335534 Slow test: "Example 5", took 3.351126 Slow test: "Example 7", took 2.804212 -------------------------------------------------- Without typechecks ------------------ Slow test: "Example 3, except part below", took 12.863874 Slow test: "True test", took 14.016901 Slow test: "Example 5", took 2.166008 Slow test: "Example 7", took 2.252685 --- module/c/cpp-util.scm | 12 ++++++------ module/c/preprocessor2.scm | 24 ++++++++++++------------ 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/module/c/cpp-util.scm b/module/c/cpp-util.scm index 7969ccd5..3ea06505 100644 --- a/module/c/cpp-util.scm +++ b/module/c/cpp-util.scm @@ -35,7 +35,7 @@ ;; - tokens until a newline token is met ;; - (potentially the newline token) and the remaining tokens (define (tokens-until-eol tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (break newline-token? tokens)) ;; call predicate with the remaining token stream, until we run out of token, or @@ -74,22 +74,22 @@ ;; Drop leading whitespace tokens (define (drop-whitespace tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (drop-while whitespace-token? tokens)) (define (drop-whitespace/line tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (drop-while (lambda (t) (and (whitespace-token? t) (not (newline-token? t)))) tokens)) (define (drop-whitespace-right tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (-> tokens reverse drop-whitespace reverse)) (define (drop-whitespace-both tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (-> tokens drop-whitespace drop-whitespace-right)) @@ -103,7 +103,7 @@ ;; "( 2, 4 )" ;; 6.10.3.2 p 2 (define (cleanup-whitespace tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (-> tokens drop-whitespace-both squeeze-whitespace)) (define (concatenate-tokens a b) diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm index 6757521f..755eaa7b 100644 --- a/module/c/preprocessor2.scm +++ b/module/c/preprocessor2.scm @@ -87,7 +87,7 @@ ;; 6.10.3.3 (define (expand## tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (let loop ((left '()) (right tokens)) @@ -203,7 +203,7 @@ (define (expand-macro environment macro noexpand-list remaining-tokens) (typecheck environment cpp-environment?) (typecheck macro cpp-macro?) - (typecheck remaining-tokens (list-of lexeme?)) + ;; (typecheck remaining-tokens (list-of lexeme?)) (typecheck noexpand-list (list-of string?)) (let ((name (macro-identifier macro))) @@ -254,7 +254,7 @@ ;; Note that this is ONLY #define f(x) forms ;; not usage forms (define (parse-identifier-list tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (let loop ((tokens (remove whitespace-token? tokens)) (done '())) (cond ((null? tokens) (values #f (reverse done))) ((identifier-token? (car tokens)) @@ -281,7 +281,7 @@ ;; Note that each returned token-list might have padding whitespace which should be trimmed. ;; It's kept to allow __VA_ARGS__ to "remember" its whitespace (define (parse-parameter-list tokens*) - (typecheck tokens* (list-of lexeme?)) + ;; (typecheck tokens* (list-of lexeme?)) (let %loop ((depth 0) (newlines 0) (current '()) (parameters '()) (tokens tokens*) (%first-iteration? #t)) (define* (loop tokens key: @@ -388,7 +388,7 @@ ;; environment, tokens → environment (define (handle-pragma environment tokens) (typecheck environment cpp-environment?) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (let ((err (lambda () (scm-error 'cpp-pragma-error "handle-pragma" @@ -413,7 +413,7 @@ (define (resolve-constant-expression tokens) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) 'TODO ) @@ -437,7 +437,7 @@ ;; environment, tokens, [boolean] → environment, tokens (define* (resolve-token-stream environment tokens key: once?) (typecheck environment cpp-environment?) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) ;; (pprint-environment environment) ;; (format (current-error-port) "~a~%~%" (unlex tokens)) (let loop ((environment environment) (tokens tokens)) @@ -462,7 +462,7 @@ ;; environment, (list token) → environment (define (resolve-for-if environment tokens) (typecheck environment cpp-environment?) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (-> (extend-environment environment defined-macro) ;; no newlines in #if line @@ -476,7 +476,7 @@ (define (maybe-extend-identifier environment identifier noexpand-list remaining-tokens) (typecheck environment cpp-environment?) (typecheck identifier string?) - (typecheck remaining-tokens (list-of lexeme?)) + ;; (typecheck remaining-tokens (list-of lexeme?)) (typecheck noexpand-list (list-of string?)) (cond ((get-identifier (join-file-line environment) identifier) => (lambda (value) @@ -492,7 +492,7 @@ (define (resolve-and-include-header environment tokens) (typecheck environment cpp-environment?) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (let ((err (lambda (msg . args) (scm-error 'cpp-error "resolve-and-include-header" @@ -522,7 +522,7 @@ ;; environment, tokens → environment (define (handle-line-directive environment tokens*) (typecheck environment cpp-environment?) - (typecheck tokens* (list-of lexeme?)) + ;; (typecheck tokens* (list-of lexeme?)) (let ((err (lambda () (scm-error 'cpp-error "handle-line-directive" "Invalid line directive: ~s" @@ -549,7 +549,7 @@ ;; environment, tokens → environment (define (resolve-define environment tokens) (typecheck environment cpp-environment?) - (typecheck tokens (list-of lexeme?)) + ;; (typecheck tokens (list-of lexeme?)) (let ((identifier (identifier-token? (car tokens))) (tail (cdr tokens))) -- cgit v1.2.3