>From 28ad796e08682d2e810041444607039fd69e79dd Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 10 Aug 2014 22:03:50 +0200 Subject: [PATCH 09/19] compiler-modules: Convert support to a module. This is quite a big module which is used throughout the compiler, so this is necessarily a very large change. I basically only went through, checked if and where identifiers were used and added them to the export list if they were used elsewhere. If they were only used in one place, I added a small note to indicate it, for a future, proper cleanup. In chicken-ffi-syntax.scm, the foreign definition macros now expand directly to support#foreign-type->scrutiny-type, and in chicken-syntax.scm, define-specialization now directly expands to support#variable-mark. This is needed in order to remove foreign-type->scrutiny-type and variable-mark from compiler-namespace. With this, a few things have been cleaned up: - The "quit" procedure has been renamed to "quit-compiling", to avoid confusion with "quit" from library.scm. - The "words" procedure has been renamed "bytes->words", for improved clarity and consistency with words->bytes. - The decompose-lambda-list alias has been removed in favor of using ##sys#decompose-lambda-list directly. Possibly this could be reverted and the alias moved into library.scm. - The "count!" and "pprint-expressions-to-file" procedures have been removed, as they were unused. - The disabled-warnings list has been removed, as it was unused. - slashify and uncommentify have been moved to c-backend, where they belong. --- batch-driver.scm | 27 +++--- c-backend.scm | 99 ++++++++++---------- c-platform.scm | 8 +- chicken-ffi-syntax.scm | 24 ++--- chicken-syntax.scm | 4 +- chicken.scm | 2 +- compiler-namespace.scm | 118 +----------------------- compiler-syntax.scm | 6 +- compiler.scm | 52 ++++++----- lfa2.scm | 6 +- optimizer.scm | 26 +++--- rules.make | 17 +++- scrutinizer.scm | 31 ++++--- support.scm | 234 +++++++++++++++++++++++++++--------------------- 14 files changed, 299 insertions(+), 355 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index 0138330..be286f9 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -31,7 +31,7 @@ (unit batch-driver) (uses extras data-structures files srfi-1 ;; TODO: Backend should be configurable - lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend) ) + support lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend) ) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -43,9 +43,9 @@ user-options-pass user-read-pass user-preprocessor-pass user-pass user-post-analysis-pass) -(import (except chicken put! get quit syntax-error) scheme +(import (except chicken put! get syntax-error) scheme extras data-structures files srfi-1 - lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend) + support lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend) (include "tweaks") @@ -63,10 +63,10 @@ (define (compile-source-file filename . options) (define (option-arg p) (if (null? (cdr p)) - (quit "missing argument to `-~A' option" (car p)) + (quit-compiling "missing argument to `-~A' option" (car p)) (let ([arg (cadr p)]) (if (symbol? arg) - (quit "invalid argument to `~A' option" arg) + (quit-compiling "invalid argument to `~A' option" arg) arg) ) ) ) (initialize-compiler) (set! explicit-use-flag (memq 'explicit-use options)) @@ -156,7 +156,7 @@ ((#\m #\M) (* (string->number (substring str 0 len1)) (* 1024 1024))) ((#\k #\K) (* (string->number (substring str 0 len1)) 1024)) (else (string->number str)) ) ) - (quit "invalid numeric argument ~S" str) ) ) ) + (quit-compiling "invalid numeric argument ~S" str) ) ) ) (define (collect-options opt) (let loop ([opts options]) @@ -262,7 +262,8 @@ (set! inline-max-size (let ([arg (option-arg inlimit)]) (or (string->number arg) - (quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) ) + (quit-compiling + "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) ) (when (memq 'case-insensitive options) (dribble "Identifiers and symbols are case insensitive") (register-feature! 'case-insensitive) @@ -272,7 +273,8 @@ (cond [(string=? "prefix" val) (keyword-style #:prefix)] [(string=? "none" val) (keyword-style #:none)] [(string=? "suffix" val) (keyword-style #:suffix)] - [else (quit "invalid argument to `-keyword-style' option")] ) ) ) + [else (quit-compiling + "invalid argument to `-keyword-style' option")] ) ) ) (when (memq 'no-parenthesis-synonyms options) (dribble "Disabled support for parenthesis synonyms") (parenthesis-synonyms #f) ) @@ -292,7 +294,7 @@ ##sys#include-pathnames ipath) ) (when (and outfile filename (string=? outfile filename)) - (quit "source- and output-filename are the same") ) + (quit-compiling "source- and output-filename are the same") ) (set! uses-units (append-map (lambda (u) (map string->symbol (string-split u ", "))) @@ -373,7 +375,7 @@ (when profile (let ((acc (eq? 'accumulate-profile (car profile)))) (when (and acc (not profile-name)) - (quit + (quit-compiling "you need to specify -profile-name if using accumulated profiling runs")) (set! emit-profile #t) (set! profiled-procedures 'all) @@ -558,11 +560,12 @@ ;;XXX hardcoded database file name (unless (memq 'ignore-repository options) (unless (load-type-database "types.db") - (quit "default type-database `types.db' not found"))) + (quit-compiling + "default type-database `types.db' not found"))) (for-each (lambda (fn) (or (load-type-database fn #f) - (quit "type-database `~a' not found" fn))) + (quit-compiling "type-database `~a' not found" fn))) (collect-options 'types)) (for-each (lambda (id) diff --git a/c-backend.scm b/c-backend.scm index bc8972b..6d1131d 100644 --- a/c-backend.scm +++ b/c-backend.scm @@ -31,7 +31,7 @@ (declare (unit c-backend) (uses srfi-1 data-structures - c-platform compiler)) + c-platform compiler support)) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -42,9 +42,9 @@ ;; For "foreign" (aka chicken-ffi-syntax): foreign-type-declaration) -(import (except chicken put! get quit syntax-error) scheme foreign +(import (except chicken put! get syntax-error) scheme foreign srfi-1 data-structures - c-platform) + c-platform support) ;;; Write atoms to output-port: @@ -63,6 +63,11 @@ (lambda (x) (display x output)) (intersperse lst #\space) ) ) +;; Hacky procedures to make certain names more suitable for use in C. +;; TODO: Slashify should probably be changed to convert \ into \\? +(define (slashify s) (string-translate (->string s) "\\" "/")) +(define (uncommentify s) (string-translate* (->string s) '(("*/" . "*_/")))) + ;;; Generate target code: (define (generate-code literals lliterals lambda-table out source-file dynamic db) @@ -685,7 +690,7 @@ [(block-variable-literal? lit) 0] [(##sys#immediate? lit) (bad-literal lit)] [(##core#inline "C_lambdainfop" lit) 0] - [(##sys#bytevector? lit) (+ 2 (words (##sys#size lit))) ] ; drops "permanent" property! + [(##sys#bytevector? lit) (+ 2 (bytes->words (##sys#size lit))) ] ; drops "permanent" property! [(##sys#generic-structure? lit) (let ([n (##sys#size lit)]) (let loop ([i 0] [s (+ 2 n)]) @@ -1155,47 +1160,47 @@ ;; Create type declarations (define (foreign-type-declaration type target) - (let ([err (lambda () (quit "illegal foreign type `~A'" type))] - [str (lambda (ts) (string-append ts " " target))] ) + (let ((err (lambda () (quit-compiling "illegal foreign type `~A'" type))) + (str (lambda (ts) (string-append ts " " target))) ) (case type - [(scheme-object) (str "C_word")] - [(char byte) (str "C_char")] - [(unsigned-char unsigned-byte) (str "unsigned C_char")] - [(unsigned-int unsigned-integer) (str "unsigned int")] - [(unsigned-int32 unsigned-integer32) (str "C_u32")] - [(int integer bool) (str "int")] - [(size_t) (str "size_t")] - [(int32 integer32) (str "C_s32")] - [(integer64) (str "C_s64")] - [(unsigned-integer64) (str "C_u64")] - [(short) (str "short")] - [(long) (str "long")] - [(unsigned-short) (str "unsigned short")] - [(unsigned-long) (str "unsigned long")] - [(float) (str "float")] - [(double number) (str "double")] - [(c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *")] - [(c-string-list c-string-list*) "C_char **"] - [(blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *")] - [(u16vector nonnull-u16vector) (str "unsigned short *")] - [(s8vector nonnull-s8vector) (str "signed char *")] - [(u32vector nonnull-u32vector) (str "unsigned int *")] - [(s16vector nonnull-s16vector) (str "short *")] - [(s32vector nonnull-s32vector) (str "int *")] - [(f32vector nonnull-f32vector) (str "float *")] - [(f64vector nonnull-f64vector) (str "double *")] + ((scheme-object) (str "C_word")) + ((char byte) (str "C_char")) + ((unsigned-char unsigned-byte) (str "unsigned C_char")) + ((unsigned-int unsigned-integer) (str "unsigned int")) + ((unsigned-int32 unsigned-integer32) (str "C_u32")) + ((int integer bool) (str "int")) + ((size_t) (str "size_t")) + ((int32 integer32) (str "C_s32")) + ((integer64) (str "C_s64")) + ((unsigned-integer64) (str "C_u64")) + ((short) (str "short")) + ((long) (str "long")) + ((unsigned-short) (str "unsigned short")) + ((unsigned-long) (str "unsigned long")) + ((float) (str "float")) + ((double number) (str "double")) + ((c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *")) + ((c-string-list c-string-list*) "C_char **") + ((blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *")) + ((u16vector nonnull-u16vector) (str "unsigned short *")) + ((s8vector nonnull-s8vector) (str "signed char *")) + ((u32vector nonnull-u32vector) (str "unsigned int *")) + ((s16vector nonnull-s16vector) (str "short *")) + ((s32vector nonnull-s32vector) (str "int *")) + ((f32vector nonnull-f32vector) (str "float *")) + ((f64vector nonnull-f64vector) (str "double *")) ((pointer-vector nonnull-pointer-vector) (str "void **")) - [(nonnull-c-string c-string nonnull-c-string* c-string* symbol) - (str "char *")] - [(nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*) - (str "unsigned char *")] - [(void) (str "void")] - [else - (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) + ((nonnull-c-string c-string nonnull-c-string* c-string* symbol) + (str "char *")) + ((nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*) + (str "unsigned char *")) + ((void) (str "void")) + (else + (cond ((and (symbol? type) (##sys#hash-table-ref foreign-type-table type)) => (lambda (t) - (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ] - [(string? type) (str type)] - [(list? type) + (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ) + ((string? type) (str type)) + ((list? type) (let ((len (length type))) (cond ((and (= 2 len) @@ -1244,14 +1249,15 @@ argtypes) ",") ")" ) ) ) - (else (err)) ) ) ] - [else (err)] ) ] ) ) ) + (else (err)) ) ) ) + (else (err)) ) ) ) ) ) ;; Generate expression to convert argument from Scheme data (define (foreign-argument-conversion type) - (let ([err (lambda () (quit "illegal foreign argument type `~A'" type))]) + (let ((err (lambda () + (quit-compiling "illegal foreign argument type `~A'" type)))) (case type ((scheme-object) "(") ((char unsigned-char) "C_character_code((C_word)") @@ -1321,7 +1327,8 @@ ;; Generate suitable conversion of a result value into Scheme data (define (foreign-result-conversion type dest) - (let ([err (lambda () (quit "illegal foreign return type `~A'" type))]) + (let ((err (lambda () + (quit-compiling "illegal foreign return type `~A'" type)))) (case type ((char unsigned-char) "C_make_character((C_word)") ((int int32) "C_fix((C_word)") diff --git a/c-platform.scm b/c-platform.scm index 4353d4a..50967db 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -31,7 +31,7 @@ (declare (unit c-platform) (uses srfi-1 data-structures - optimizer)) + optimizer support)) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -46,9 +46,9 @@ target-include-file words-per-flonum parameter-limit small-parameter-limit) -(import (except chicken put! get quit syntax-error) scheme +(import (except chicken put! get syntax-error) scheme srfi-1 data-structures - optimizer) + optimizer support) (include "tweaks") @@ -1090,7 +1090,7 @@ (and-let* ([proc (get db (first (node-parameters val)) 'value)] [(eq? '##core#lambda (node-class proc))] ) (let ([llist (third (node-parameters proc))]) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (and (= argc 2) diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm index 57acabb..0e749f5 100644 --- a/chicken-ffi-syntax.scm +++ b/chicken-ffi-syntax.scm @@ -31,7 +31,7 @@ (fixnum)) ;; IMPORTANT: These macros expand directly into fully qualified names -;; from the c-backend module. +;; from the "c-backend" and "support" modules. #+(not debugbuild) (declare @@ -173,7 +173,7 @@ 'foreign-value "bad argument type - not a string or symbol" code)))) - (##core#the ,(##compiler#foreign-type->scrutiny-type + (##core#the ,(support#foreign-type->scrutiny-type (##sys#strip-syntax (caddr form)) 'result) #f ,tmp) ) ) ) ) ) @@ -217,8 +217,8 @@ (args (##sys#strip-syntax (if hasrtype (caddr form) (cadr form)))) (argtypes (map car args))) `(##core#the (procedure - ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg) argtypes) - ,(##compiler#foreign-type->scrutiny-type rtype 'result)) + ,(map (cut support#foreign-type->scrutiny-type <> 'arg) argtypes) + ,(support#foreign-type->scrutiny-type rtype 'result)) #f (##core#foreign-primitive ,@(cdr form))))))) @@ -229,9 +229,9 @@ (lambda (form r c) (##sys#check-syntax 'foreign-lambda form '(_ _ _ . _)) `(##core#the - (procedure ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg) + (procedure ,(map (cut support#foreign-type->scrutiny-type <> 'arg) (##sys#strip-syntax (cdddr form))) - ,(##compiler#foreign-type->scrutiny-type + ,(support#foreign-type->scrutiny-type (##sys#strip-syntax (cadr form)) 'result)) #f (##core#foreign-lambda ,@(cdr form)))))) @@ -243,9 +243,9 @@ (lambda (form r c) (##sys#check-syntax 'foreign-lambda* form '(_ _ _ _ . _)) `(##core#the - (procedure ,(map (lambda (a) (##compiler#foreign-type->scrutiny-type (car a) 'arg)) + (procedure ,(map (lambda (a) (support#foreign-type->scrutiny-type (car a) 'arg)) (##sys#strip-syntax (caddr form))) - ,(##compiler#foreign-type->scrutiny-type + ,(support#foreign-type->scrutiny-type (##sys#strip-syntax (cadr form)) 'result)) #f (##core#foreign-lambda* ,@(cdr form)))))) @@ -257,9 +257,9 @@ (lambda (form r c) (##sys#check-syntax 'foreign-safe-lambda form '(_ _ _ . _)) `(##core#the - (procedure ,(map (cut ##compiler#foreign-type->scrutiny-type <> 'arg) + (procedure ,(map (cut support#foreign-type->scrutiny-type <> 'arg) (##sys#strip-syntax (cdddr form))) - ,(##compiler#foreign-type->scrutiny-type + ,(support#foreign-type->scrutiny-type (##sys#strip-syntax (cadr form)) 'result)) #f (##core#foreign-safe-lambda ,@(cdr form)))))) @@ -271,9 +271,9 @@ (lambda (form r c) (##sys#check-syntax 'foreign-safe-lambda* form '(_ _ _ _ . _)) `(##core#the - (procedure ,(map (lambda (a) (##compiler#foreign-type->scrutiny-type (car a) 'arg)) + (procedure ,(map (lambda (a) (support#foreign-type->scrutiny-type (car a) 'arg)) (##sys#strip-syntax (caddr form))) - ,(##compiler#foreign-type->scrutiny-type + ,(support#foreign-type->scrutiny-type (##sys#strip-syntax (cadr form)) 'result)) #f (##core#foreign-safe-lambda* ,@(cdr form)))))) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 46d3cbc..35335be 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -31,7 +31,7 @@ (fixnum) ) ;; IMPORTANT: These macros expand directly into fully qualified names -;; from the scrutinizer module. +;; from the scrutinizer and support modules. #+(not debugbuild) (declare @@ -1244,7 +1244,7 @@ rtypes) spec) (list spec)))) - (or (##compiler#variable-mark + (or (support#variable-mark gname '##compiler#local-specializations) '()))) diff --git a/chicken.scm b/chicken.scm index 0ef388b..79c7833 100644 --- a/chicken.scm +++ b/chicken.scm @@ -144,7 +144,7 @@ ((memq o valid-compiler-options-with-argument) (if (pair? rest) (loop (cdr rest)) - (quit "missing argument to `-~s' option" o) ) ) + (quit-compiling "missing argument to `-~s' option" o) ) ) (else (warning "invalid compiler option (ignored)" diff --git a/compiler-namespace.scm b/compiler-namespace.scm index 9a7516c..2a6a0fc 100644 --- a/compiler-namespace.scm +++ b/compiler-namespace.scm @@ -28,44 +28,17 @@ compiler analyze-expression all-import-libraries - banner - basic-literal? - big-fixnum? block-compilation - block-variable-literal-name - block-variable-literal? bootstrap-mode - bomb broken-constant-nodes - build-expression-tree - build-lambda-list - build-node-graph - c-ify-string callback-names - call-info - canonicalize-begin-body canonicalize-expression - check-and-open-input-file - check-signature - chop-extension - chop-separator - close-checked-input-file - collapsable-literal? - collect! - collected-debugging-output compile-format-string compiler-arguments - compiler-cleanup-hook compiler-source-file compiler-syntax-enabled - compute-database-statistics - constant-form-eval constant-table - constant? constants-used - copy-node! - copy-node-tree-and-rename - count! create-foreign-stub csc-control-file current-program-size @@ -74,10 +47,8 @@ debug-info-vector-name debug-lambda-list debug-variable-list - debugging debugging-chicken debugging-executable - decompose-lambda-list default-default-target-heap-size default-extended-bindings default-optimization-iterations @@ -87,24 +58,12 @@ dependency-list direct-call-ids disable-stack-overflow-checking - disabled-warnings - display-analysis-database - display-line-number-database - display-real-name-table - dump-defined-globals - dump-global-refs - dump-nodes - dump-undefined-globals emit-closure-info emit-control-file-item - emit-global-inline-file emit-profile - emit-syntax-trace-info emit-trace-info enable-inline-files enable-specialization - estimate-foreign-result-location-size - estimate-foreign-result-size expand-debug-assignment expand-debug-call expand-debug-lambda @@ -113,27 +72,18 @@ expand-foreign-lambda expand-foreign-lambda* expand-foreign-primitive - expand-profile-lambda explicit-use-flag export-dump-hook - export-variable - expression-has-side-effects? extended-bindings external-protos-first external-to-pointer external-variables file-io-only file-requirements - final-foreign-type find-early-refs find-inlining-candidates - finish-foreign-result first-analysis - fold-boolean - fold-inner - foldable? foldable-bindings - follow-without-loop foreign-callback-stubs foreign-callback-stub-argument-types foreign-callback-stub-body @@ -155,25 +105,11 @@ foreign-stub-name foreign-stub-qualifiers foreign-stub-return-type - foreign-type->scrutiny-type - foreign-type-check - foreign-type-convert-argument - foreign-type-convert-result foreign-type-table foreign-variables - get - get-all - get-line - get-line-2 - get-list - hide-variable - immediate? immutable-constants import-libraries - read-info-hook - initialize-analysis-database initialize-compiler - inline-lambda-bindings inline-locally inline-max-size inline-substitutions-enabled @@ -183,7 +119,6 @@ insert-timer-checks installation-home internal-bindings - intrinsic? line-number-database-2 line-number-database-size lambda-literal-id @@ -203,28 +138,13 @@ rest-argument-mode lambda-literal-body lambda-literal-direct - llist-length - llist-match? - load-identifier-database - load-inline-file local-definitions location-pointer-map - make-block-variable-literal - make-random-name - mark-variable - match-node no-argc-checks no-bound-checks no-global-procedure-checks enable-module-registration no-procedure-checks - node-class - node-class-set! - node-parameters - node-parameters-set! - node->sexpr - node-subexpressions - node-subexpressions-set! nonwinding-call/cc number-type optimization-iterations @@ -235,56 +155,27 @@ perform-closure-conversion perform-cps-conversion perform-inlining! - posv - posq postponed-initforms - pprint-expressions-to-file prepare-for-code-generation - print-debug-options - print-program-statistics - print-usage - print-version process-command-line process-declaration profile-info-vector-name profile-lambda-index profile-lambda-list profiled-procedures - put! - qnode - quit - read/source-info - real-name real-name-table - real-name2 register-unboxed-op require-imports-flag rest-parameters-promoted-to-vector safe-globals-flag - scan-free-variables - scan-sharp-greater-string - scan-used-variables - set-real-name! - sexpr->node - simple-lambda-node? - slashify - sort-symbols source-filename - source-info->string - source-info->line standalone-executable standard-bindings strict-variable-types - string->c-identifier - string->expr - stringify - symbolify target-heap-size target-stack-size toplevel-lambda-id toplevel-scope - tree-copy - uncommentify undefine-shadowed-macros unit-name unlikely-variables @@ -292,11 +183,4 @@ update-line-number-database update-line-number-database! used-units - valid-c-identifier? - variable-mark - variable-visible? - varnode - verbose-mode - with-debugging-output - words - words->bytes) + verbose-mode) diff --git a/compiler-syntax.scm b/compiler-syntax.scm index 030e918..7c42bf2 100644 --- a/compiler-syntax.scm +++ b/compiler-syntax.scm @@ -26,7 +26,8 @@ (declare (unit compiler-syntax) - (uses srfi-1 data-structures) ) + (uses srfi-1 data-structures + support) ) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -35,7 +36,8 @@ (module compiler-syntax (compiler-syntax-statistics) -(import chicken scheme srfi-1 data-structures) +(import (except chicken put! get syntax-error) scheme srfi-1 data-structures + support) (include "tweaks.scm") diff --git a/compiler.scm b/compiler.scm index 1c0b472..ce31f96 100644 --- a/compiler.scm +++ b/compiler.scm @@ -263,9 +263,10 @@ (declare - (unit compiler)) + (unit compiler) + (uses scrutinizer support) ) -(import scrutinizer) +(import scrutinizer support) (include "compiler-namespace") @@ -659,7 +660,7 @@ (llist obody) (##sys#expand-extended-lambda-list llist obody ##sys#error se) ) ) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (let* ((aliases (map gensym vars)) @@ -1095,7 +1096,7 @@ (set! location-pointer-map (cons (list alias store type) location-pointer-map) ) (walk - `(let (,(let ([size (words (estimate-foreign-result-location-size type))]) + `(let (,(let ([size (bytes->words (estimate-foreign-result-location-size type))]) ;; Add 2 words: 1 for the header, 1 for double-alignment: ;; Note: C_a_i_bytevector takes number of words, not bytes (list @@ -1123,7 +1124,7 @@ [valexp (third x)] [val (handle-exceptions ex ;; could show line number here - (quit "error in constant evaluation of ~S for named constant `~S'" + (quit-compiling "error in constant evaluation of ~S for named constant `~S'" valexp name) (if (and (not (symbol? valexp)) (collapsable-literal? valexp)) @@ -1145,7 +1146,7 @@ (mark-variable var '##compiler#always-bound) (walk `(define ,var ',val) e se #f #f h ln) ) ) (else - (quit "invalid compile-time value for named constant `~S'" + (quit-compiling "invalid compile-time value for named constant `~S'" name))))) ((##core#declare) @@ -1170,7 +1171,7 @@ (if (valid-c-identifier? raw-c-name) (set! callback-names (cons (cons raw-c-name name) callback-names)) - (quit "name `~S' of external definition is not a valid C identifier" + (quit-compiling "name `~S' of external definition is not a valid C identifier" raw-c-name) ) (when (or (not (proper-list? vars)) (not (proper-list? atypes)) @@ -1482,7 +1483,8 @@ (for-each (cut mark-variable <> '##compiler#pure #t) (globalize-all syms)) - (quit "invalid arguments to `constant' declaration: ~S" spec)) ) ) + (quit-compiling + "invalid arguments to `constant' declaration: ~S" spec)) ) ) ((emit-import-library) (set! import-libraries (append @@ -1630,19 +1632,21 @@ ,(if (zero? rsize) (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype) (let ([ft (final-foreign-type rtype)] - [ws (words rsize)] ) + [ws (bytes->words rsize)] ) `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)]) ,(foreign-type-convert-result (finish-foreign-result ft (append head (cons bufvar rest))) rtype) ) ) ) ) ) ) ) (define (expand-foreign-lambda exp callback?) - (let* ([name (third exp)] - [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name))) + (let* ((name (third exp)) + (sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name))) ((string? name) name) - (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ] - [rtype (second exp)] - [argtypes (cdddr exp)] ) + (else (quit-compiling + "name `~s' of foreign procedure has wrong type" + name)) ) ) + (rtype (second exp)) + (argtypes (cdddr exp)) ) (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) ) (define (expand-foreign-lambda* exp callback?) @@ -1887,7 +1891,7 @@ ((lambda) ; this is an intermediate lambda, slightly different (grow 1) ; from '##core#lambda nodes (params = (LLIST)); - (decompose-lambda-list ; CPS will convert this into ##core#lambda + (##sys#decompose-lambda-list ; CPS will convert this into ##core#lambda (first params) (lambda (vars argc rest) (for-each @@ -1900,7 +1904,7 @@ ((##core#lambda ##core#direct_lambda) (grow 1) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (let ([id (first params)] @@ -2128,7 +2132,7 @@ (= nreferences ncall-sites) ) (let ([lparams (node-parameters value)]) (when (second lparams) - (decompose-lambda-list + (##sys#decompose-lambda-list (third lparams) (lambda (vars argc rest) (unless rest @@ -2297,7 +2301,7 @@ (proper-list? llist) ) ] ) (when (and name (not (llist-match? llist (cdr subs)))) - (quit + (quit-compiling "~a: procedure `~a' called with wrong number of arguments" (source-info->line name) (if (pair? name) (cadr name) name))) @@ -2310,7 +2314,7 @@ (concatenate (map (lambda (n) (gather n here locals)) subs) ) )) ((##core#lambda ##core#direct_lambda) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (let ((id (if here (first params) 'toplevel))) @@ -2363,7 +2367,7 @@ ((##core#lambda ##core#direct_lambda) (let ([llist (third params)]) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)] @@ -2569,11 +2573,11 @@ (make-node class params (mapwalk subs e e-count here boxes)) ) ((##core#inline_ref) - (set! allocated (+ allocated (words (estimate-foreign-result-size (second params))))) + (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (second params))))) (make-node class params '()) ) ((##core#inline_loc_ref) - (set! allocated (+ allocated (words (estimate-foreign-result-size (first params))))) + (set! allocated (+ allocated (bytes->words (estimate-foreign-result-size (first params))))) (make-node class params (mapwalk subs e e-count here boxes)) ) ((##core#closure) @@ -2608,7 +2612,7 @@ (set! allocated 0) (set! signatures '()) (set! looping 0) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (let* ([id (first params)] @@ -2730,7 +2734,7 @@ "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c))) (immediate-literal (inexact->exact c)) ) - (else (quit "cannot coerce inexact literal `~S' to fixnum" c)) ) ) + (else (quit-compiling "cannot coerce inexact literal `~S' to fixnum" c)) ) ) (else (make-node '##core#literal (list (literal c)) '())) ) ) ((immediate? c) (immediate-literal c)) (else (make-node '##core#literal (list (literal c)) '())) ) ) ) diff --git a/lfa2.scm b/lfa2.scm index 4d25e63..3e58989 100644 --- a/lfa2.scm +++ b/lfa2.scm @@ -34,7 +34,8 @@ (declare (unit lfa2) - (uses srfi-1) ) + (uses srfi-1 + support) ) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -43,7 +44,8 @@ (module lfa2 (perform-secondary-flow-analysis) -(import (except chicken put! get quit syntax-error) scheme srfi-1) +(import (except chicken put! get syntax-error) scheme srfi-1 + support) (include "tweaks") diff --git a/optimizer.scm b/optimizer.scm index a908b5d..1b54c51 100644 --- a/optimizer.scm +++ b/optimizer.scm @@ -27,7 +27,8 @@ (declare (unit optimizer) - (uses srfi-1 data-structures) ) + (uses srfi-1 data-structures + support) ) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -39,8 +40,9 @@ eq-inline-operator membership-test-operators membership-unfold-limit default-optimization-passes rewrite) -(import (except chicken put! get quit syntax-error) scheme - srfi-1 data-structures) +(import (except chicken put! get syntax-error) scheme + srfi-1 data-structures + support) (include "tweaks") @@ -283,7 +285,7 @@ (let ((llist (third params)) (id (first params))) (cond [(test id 'has-unused-parameters) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (receive (unused used) (partition (lambda (v) (test v 'unused)) vars) @@ -300,7 +302,7 @@ (fourth params) ) (list (walk (first subs) (cons id fids) '())) ) ) ) ) ] [(test id 'explicit-rest) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (touch) @@ -372,7 +374,7 @@ ;; callee is a lambda (let* ([lparams (node-parameters lval)] [llist (third lparams)] ) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (let ((ifid (first lparams)) @@ -1394,7 +1396,7 @@ #t) ) ) ) ] [(##core#lambda) (and v - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (set! closures (cons v closures)) @@ -1491,7 +1493,7 @@ (set! ksites (alist-cons #f n ksites)) (cond [(eq? kvar (first arg0p)) (unless (= argc (length (cdr subs))) - (quit + (quit-compiling "known procedure called recursively with wrong number of arguments: `~A'" fnvar) ) (node-class-set! n '##core#recurse) @@ -1502,7 +1504,7 @@ (let* ([klam (cdr a)] [kbody (first (node-subexpressions klam))] ) (unless (= argc (length (cdr subs))) - (quit + (quit-compiling "known procedure called recursively with wrong number of arguments: `~A'" fnvar) ) (node-class-set! n 'let) @@ -1534,7 +1536,7 @@ (let* ([n (cdr site)] [nsubs (node-subexpressions n)] ) (unless (= argc (length (cdr nsubs))) - (quit + (quit-compiling "known procedure called with wrong number of arguments: `~A'" fnvar) ) (node-subexpressions-set! @@ -1642,7 +1644,7 @@ (walk val e) (walk body (cons var e)))))) ((##core#lambda ##core#direct_lambda) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) ;; walk recursively, with cleared cluster state @@ -1676,7 +1678,7 @@ (pparams (node-parameters proc)) (llist (third pparams)) (aliases (map gensym llist))) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (let ((body (first (node-subexpressions proc))) diff --git a/rules.make b/rules.make index 85e7528..3996455 100644 --- a/rules.make +++ b/rules.make @@ -492,7 +492,7 @@ endef $(foreach lib, $(SETUP_API_OBJECTS_1),\ $(eval $(call declare-emitted-import-lib-dependency,$(lib)))) -$(foreach lib, batch-driver lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend,\ +$(foreach lib, batch-driver lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend support,\ $(eval $(call declare-emitted-import-lib-dependency,$(lib)))) chicken.c: chicken.scm batch-driver.import.scm batch-driver.scm \ @@ -502,9 +502,18 @@ batch-driver.c: batch-driver.scm lfa2.import.scm lfa2.scm \ optimizer.scm optimizer.import.scm \ scrutinizer.scm scrutinizer.import.scm \ c-platform.scm c-platform.import.scm \ - c-backend.scm c-backend.import.scm -c-platform.c: c-platform.scm optimizer.scm optimizer.import.scm -c-backend.c: c-backend.scm c-platform.scm c-platform.import.scm compiler.scm + c-backend.scm c-backend.import.scm \ + support.scm support.import.scm +c-platform.c: c-platform.scm optimizer.scm optimizer.import.scm \ + support.scm support.import.scm +c-backend.c: c-backend.scm c-platform.scm c-platform.import.scm \ + support.scm support.import.scm compiler.scm +compiler.c: compiler.scm scrutinizer.scm scrutinizer.import.scm \ + support.scm support.import.scm +optimizer.c: optimizer.scm support.scm support.import.scm +scrutinizer.c: scrutinizer.scm support.scm support.import.scm +lfa2.c: lfa2.scm support.scm support.import.scm +compiler-syntax.c: compiler-syntax.scm support.scm support.import.scm define profile-flags $(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile) diff --git a/scrutinizer.scm b/scrutinizer.scm index acb057b..3eed5b6 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -26,7 +26,8 @@ (declare (unit scrutinizer) - (uses srfi-1 data-structures extras ports files) ) + (uses srfi-1 data-structures extras ports files + support) ) ;; TODO: Remove these once everything's converted to modules (include "private-namespace") @@ -36,8 +37,9 @@ (scrutinize load-type-database emit-type-file validate-type check-and-validate-type install-specializations) -(import (except chicken put! get quit syntax-error) scheme - srfi-1 data-structures extras ports files) +(import (except chicken put! get syntax-error) scheme + srfi-1 data-structures extras ports files + support) (include "tweaks") @@ -554,7 +556,7 @@ (set! aliased (alist-cons var var2 aliased))))) (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2)))))) ((##core#lambda lambda) - (decompose-lambda-list + (##sys#decompose-lambda-list (first params) (lambda (vars argc rest) (let* ((namelst (if dest (list dest) '())) @@ -822,15 +824,16 @@ ;; first exp is always a variable so ts must be of length 1 (let loop ((types (cdr params)) (subs (cdr subs))) (cond ((null? types) - (quit "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a" - (location-name loc) - (if (first params) - (sprintf "(~a) " (first params)) - "") - (car ts) - (string-intersperse - (map (lambda (t) (sprintf "\n ~a" t)) - (cdr params)) ""))) + (quit-compiling + "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a" + (location-name loc) + (if (first params) + (sprintf "(~a) " (first params)) + "") + (car ts) + (string-intersperse + (map (lambda (t) (sprintf "\n ~a" t)) + (cdr params)) ""))) ((match-types (car types) (car ts) (append (type-typeenv (car types)) typeenv) #t) @@ -864,7 +867,7 @@ (when (positive? dropped-branches) (debugging '(o e) "dropped branches" dropped-branches)) (when errors - (quit "some variable types do not satisfy strictness")) + (quit-compiling "some variable types do not satisfy strictness")) rn))) diff --git a/support.scm b/support.scm index d91f53b..c08cd27 100644 --- a/support.scm +++ b/support.scm @@ -25,24 +25,57 @@ ; POSSIBILITY OF SUCH DAMAGE. -(declare - (unit support)) - +(declare (unit support) + (not inline ##sys#user-read-hook) ; XXX: Is this needed? + (uses data-structures srfi-1 files extras ports) ) +;; TODO: Remove these once everything's converted to modules +(include "private-namespace") (include "compiler-namespace") -(include "tweaks") -(include "banner") -(declare - (not inline compiler-cleanup-hook ##sys#user-read-hook) ) +(module support + (compiler-cleanup-hook bomb collected-debugging-output debugging + with-debugging-output quit-compiling emit-syntax-trace-info + check-signature posq posv stringify symbolify + build-lambda-list string->c-identifier c-ify-string valid-c-identifier? + bytes->words words->bytes + check-and-open-input-file close-checked-input-file fold-inner + constant? collapsable-literal? immediate? basic-literal? + canonicalize-begin-body string->expr llist-length llist-match? + expand-profile-lambda initialize-analysis-database get get-all put! + collect! get-list get-line get-line-2 display-line-number-database + display-analysis-database make-node node? node-class node-class-set! + node-parameters node-parameters-set! + node-subexpressions node-subexpressions-set! varnode qnode + build-node-graph build-expression-tree fold-boolean inline-lambda-bindings + tree-copy copy-node! emit-global-inline-file load-inline-file + match-node expression-has-side-effects? simple-lambda-node? + dump-undefined-globals dump-defined-globals dump-global-refs + print-program-statistics foreign-type-check foreign-type-convert-result + foreign-type-convert-argument final-foreign-type + estimate-foreign-result-size estimate-foreign-result-location-size + finish-foreign-result foreign-type->scrutiny-type scan-used-variables + scan-free-variables chop-separator + make-block-variable-literal block-variable-literal? + block-variable-literal-name make-random-name + set-real-name! real-name real-name2 display-real-name-table + source-info->string source-info->line call-info constant-form-eval + dump-nodes read-info-hook read/source-info big-fixnum? + hide-variable export-variable variable-visible? + mark-variable variable-mark intrinsic? foldable? load-identifier-database + print-version print-usage print-debug-options) + +(import (except chicken put! get syntax-error) scheme foreign + data-structures srfi-1 files extras ports) +(include "tweaks") +(include "banner") ;;; Debugging and error-handling stuff: (define (compiler-cleanup-hook) #f) (define debugging-chicken '()) -(define disabled-warnings '()) ; usage type load var const syntax redef use call ffi (define (bomb . msg-and-args) (if (pair? msg-and-args) @@ -100,7 +133,7 @@ ((test-mode mode +logged-debugging-modes+) (collect (with-output-to-string thunk))))) -(define (quit msg . args) +(define (quit-compiling msg . args) (let ([out (current-error-port)]) (apply fprintf out (string-append "\nError: " msg) args) (newline out) @@ -123,6 +156,7 @@ (set! syntax-error ##sys#syntax-error-hook) +;; Move to C-platform? (define (emit-syntax-trace-info info cntr) (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) @@ -132,11 +166,13 @@ [(symbol? llist) (proc llist)] [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) ) +;; XXX: Shouldn't this be in optimizer.scm? (define (check-signature var args llist) (define (err) - (quit "Arguments to inlined call of `~A' do not match parameter-list ~A" - (real-name var) - (map-llist real-name (cdr llist)) ) ) + (quit-compiling + "Arguments to inlined call of `~A' do not match parameter-list ~A" + (real-name var) + (map-llist real-name (cdr llist)) ) ) (let loop ([as args] [ll llist]) (cond [(null? ll) (unless (null? as) (err))] [(symbol? ll)] @@ -146,6 +182,7 @@ ;;; Generic utility routines: +;; XXX: Don't posq and posv belong better in library or data-structures? (define (posq x lst) (let loop ([lst lst] [i 0]) (cond [(null? lst) #f] @@ -168,17 +205,15 @@ ((string? x) (string->symbol x)) (else (string->symbol (sprintf "~a" x))) ) ) -(define (slashify s) (string-translate (->string s) "\\" "/")) - -(define (uncommentify s) (string-translate* (->string s) '(("*/" . "*_/")))) - (define (build-lambda-list vars argc rest) (let loop ((vars vars) (n argc)) (cond ((or (zero? n) (null? vars)) (or rest '())) (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) ) +;; XXX: This seems to belong to c-platform, but why is it defined in eval.scm? (define string->c-identifier ##sys#string->c-identifier) +;; XXX: Put this too in c-platform or c-backend? (define (c-ify-string str) (list->string (cons @@ -197,6 +232,7 @@ (loop (cdr chars)) ) (cons c (loop (cdr chars))) ) ) ) ) ) ) ) +;; XXX: This too, but it's used only in compiler.scm, WTF? (define (valid-c-identifier? name) (let ([str (string->list (->string name))]) (and (pair? str) @@ -206,21 +242,23 @@ (cdr str) ) ) ) ) ) ) (eval-when (load) - (define words (foreign-lambda int "C_bytestowords" int)) + (define bytes->words (foreign-lambda int "C_bytestowords" int)) (define words->bytes (foreign-lambda int "C_wordstobytes" int)) ) (eval-when (eval) - (define (words n) + (define (bytes->words n) (let ([wordsize (##sys#fudge 7)]) (+ (quotient n wordsize) (if (zero? (modulo n wordsize)) 0 1)) ) ) (define (words->bytes n) (* n (##sys#fudge 7)) ) ) +;; Used only in batch-driver; move it there? (define (check-and-open-input-file fname . line) - (cond [(string=? fname "-") (current-input-port)] - [(file-exists? fname) (open-input-file fname)] - [(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)] - [else (quit "(~a) can not open file ~s" (car line) fname)] ) ) + (cond ((string=? fname "-") (current-input-port)) + ((file-exists? fname) (open-input-file fname)) + ((or (null? line) (not (car line))) + (quit-compiling "Can not open file ~s" fname)) + (else (quit-compiling "(~a) can not open file ~s" (car line) fname)) ) ) (define (close-checked-input-file port fname) (unless (string=? fname "-") (close-input-port port)) ) @@ -297,16 +335,17 @@ (else `(let ((,(gensym 't) ,(car xs))) ,(loop (cdr xs))) ) ) ) ) +;; Only used in batch-driver: move it there? (define string->expr (let ([exn? (condition-predicate 'exn)] [exn-msg (condition-property-accessor 'exn 'message)] ) (lambda (str) (handle-exceptions ex - (quit "cannot parse expression: ~s [~a]~%" - str - (if (exn? ex) - (exn-msg ex) - (->string ex) ) ) + (quit-compiling "cannot parse expression: ~s [~a]~%" + str + (if (exn? ex) + (exn-msg ex) + (->string ex) ) ) (let ([xs (with-input-from-string str (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))]) @@ -314,8 +353,8 @@ [(null? (cdr xs)) (car xs)] [else `(begin ,@xs)] ) ) ) ) ) ) -(define decompose-lambda-list ##sys#decompose-lambda-list) - +;; Only used in optimizer; move it there? But it's a C function call, so +;; it may be better in c-platform (define (llist-length llist) (##core#inline "C_u_i_length" llist)) ; stops at non-pair node @@ -370,6 +409,7 @@ internal-bindings)) (set! initial #f)))) +;; TODO: Rename this to avoid conflict/confusion with the one from scheme (define (get db key prop) (let ((plist (##sys#hash-table-ref db key))) (and plist @@ -382,6 +422,7 @@ (filter-map (lambda (prop) (assq prop plist)) props) '() ) ) ) +;; TODO: Rename this to avoid conflict/confusion with the one from scheme (define (put! db key prop val) (let ([plist (##sys#hash-table-ref db key)]) (if plist @@ -398,15 +439,6 @@ [else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) ) (##sys#hash-table-set! db key (list (list prop val)))) ) ) -(define (count! db key prop . val) - (let ([plist (##sys#hash-table-ref db key)] - [n (if (pair? val) (car val) 1)] ) - (if plist - (let ([a (assq prop plist)]) - (cond [a (##sys#setslot a 1 (+ (##sys#slot a 1) n))] - [else (##sys#setslot plist 1 (alist-cons prop n (##sys#slot plist 1)))] ) ) - (##sys#hash-table-set! db key (list (cons prop val)))) ) ) - (define (get-list db key prop) ; returns '() if not set (let ((x (get db key prop))) (or x '()))) @@ -679,8 +711,9 @@ (list (proc (first vars) (second vars)) (fold (cdr vars)) ) ) ) ) ) +;; Move to optimizer.scm? (define (inline-lambda-bindings llist args body copy? db cfk) - (decompose-lambda-list + (##sys#decompose-lambda-list llist (lambda (vars argc rest) (receive (largs rargs) (split-at args argc) @@ -704,6 +737,7 @@ (take rlist argc) largs) ) ) ) ) ) +;; Copy along with the above (define (copy-node-tree-and-rename node vars aliases db cfk) (let ([rlist (map cons vars aliases)]) (define (rename v rl) (alist-ref v rl eq? v)) @@ -733,7 +767,7 @@ 'let (list a) (list val1 (walk (second subs) rl2)))) ] [(##core#lambda) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (let* ((as (map (lambda (v) @@ -751,6 +785,7 @@ [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) ) (walk node rlist) ) ) +;; Maybe move to scrutinizer. It's generic enough to keep it here though (define (tree-copy t) (let rec ([t t]) (if (pair? t) @@ -773,6 +808,7 @@ (let walk ((x x)) (make-node (car x) (cadr x) (map walk (cddr x))))) +;; Only used in batch-driver.scm (define (emit-global-inline-file filename db) (let ((lst '()) (out '())) @@ -811,6 +847,7 @@ (debugging 'i "the following procedures can be globally inlined:")) (for-each (cut print " " <>) (sort-symbols lst))))) +;; Used only in batch-driver.scm (define (load-inline-file fname) (with-input-from-file fname (lambda () @@ -826,7 +863,7 @@ ;;; Match node-structure with pattern: -(define (match-node node pat vars) +(define (match-node node pat vars) ; Only used in optimizer.scm (let ((env '())) (define (resolve v x) @@ -877,7 +914,7 @@ [(if let) (any walk subs)] [else #t] ) ) ) ) -(define (simple-lambda-node? node) +(define (simple-lambda-node? node) ; Used only in compiler.scm (let* ([params (node-parameters node)] [llist (third params)] [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument @@ -897,7 +934,7 @@ ;;; Some safety checks and database dumping: -(define (dump-undefined-globals db) +(define (dump-undefined-globals db) ; Used only in batch-driver.scm (##sys#hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) @@ -907,7 +944,7 @@ (newline) ) ) db) ) -(define (dump-defined-globals db) +(define (dump-defined-globals db) ; Used only in batch-driver.scm (##sys#hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) @@ -917,7 +954,7 @@ (newline) ) ) db) ) -(define (dump-global-refs db) +(define (dump-global-refs db) ; Used only in batch-driver.scm (##sys#hash-table-for-each (lambda (sym plist) (when (and (not (keyword? sym)) (assq 'global plist)) @@ -977,7 +1014,7 @@ nsites entries) ) ) -(define (print-program-statistics db) +(define (print-program-statistics db) ; Used only in batch-driver.scm (receive (size osize kvars kprocs globs sites entries) (compute-database-statistics db) (when (debugging 's "program statistics:") @@ -989,23 +1026,9 @@ (printf "; database entries: \t~s\n" entries) ) ) ) -;;; Pretty-print expressions: - -(define (pprint-expressions-to-file exps filename) - (let ([port (if filename (open-output-file filename) (current-output-port))]) - (with-output-to-port port - (lambda () - (for-each - (lambda (x) - (pretty-print x) - (newline) ) - exps) ) ) - (when filename (close-output-port port)) ) ) - - ;;; Create foreign type checking expression: -(define foreign-type-check +(define foreign-type-check ; Used only in compiler.scm (let ((tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector) (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector) (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector) @@ -1134,26 +1157,27 @@ `(##sys#foreign-pointer-argument ,param) ] [else param] ) ] [else param] ) ] ) ) ) - (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) ) + (lambda () + (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) ) ;;; Compute foreign-type conversions: -(define (foreign-type-convert-result r t) +(define (foreign-type-convert-result r t) ; Used only in compiler.scm (or (and-let* ([(symbol? t)] [ft (##sys#hash-table-ref foreign-type-table t)] [(vector? ft)] ) (list (vector-ref ft 2) r) ) r) ) -(define (foreign-type-convert-argument a t) +(define (foreign-type-convert-argument a t) ; Used only in compiler.scm (or (and-let* ([(symbol? t)] [ft (##sys#hash-table-ref foreign-type-table t)] [(vector? ft)] ) (list (vector-ref ft 1) a) ) a) ) -(define (final-foreign-type t0) +(define (final-foreign-type t0) ; Used only in compiler.scm (follow-without-loop t0 (lambda (t next) @@ -1161,7 +1185,7 @@ => (lambda (t2) (next (if (vector? t2) (vector-ref t2 0) t2)) ) ] [else t] ) ) - (lambda () (quit "foreign type `~S' refers to itself" t0)) ) ) + (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) ) ;;; Compute foreign result size: @@ -1192,11 +1216,11 @@ (words->bytes 3) ] [else 0] ) ] [else 0] ) ) ) ) - (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) + (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) ) -(define (estimate-foreign-result-location-size type) +(define (estimate-foreign-result-location-size type) ; Used only in compiler.scm (define (err t) - (quit "cannot compute size of location for foreign type `~S'" t) ) + (quit-compiling "cannot compute size of location for foreign type `~S'" t) ) (follow-without-loop type (lambda (t next) @@ -1220,12 +1244,12 @@ (words->bytes 1)] [else (err t)] ) ] [else (err t)] ) ) ) ) - (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) + (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ;;; Convert result value, if a string: -(define (finish-foreign-result type body) +(define (finish-foreign-result type body) ; Used only in compiler.scm (let ((type (##sys#strip-syntax type))) (case type [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)] @@ -1261,6 +1285,7 @@ ;;; Translate foreign-type into scrutinizer type: +;; Used only in chicken-ffi-syntax.scm; can we move it there? (define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result (let ((ft (final-foreign-type t))) (case ft @@ -1361,7 +1386,7 @@ (walk (first subs) e) (walk (second subs) (append params e)) ) ((##core#lambda) - (decompose-lambda-list + (##sys#decompose-lambda-list (third params) (lambda (vars argc rest) (walk (first subs) (append vars e)) ) ) ) @@ -1376,21 +1401,13 @@ ;;; Some pathname operations: -(define (chop-separator str) +(define (chop-separator str) ; Used only in batch-driver.scm (let ([len (sub1 (string-length str))]) (if (and (> len 0) (memq (string-ref str len) '(#\\ #\/))) (substring str 0 len) str) ) ) -(define (chop-extension str) - (let ([len (sub1 (string-length str))]) - (let loop ([i len]) - (cond [(zero? i) str] - [(char=? #\. (string-ref str i)) (substring str 0 i)] - [else (loop (sub1 i))] ) ) ) ) - - ;;; Special block-variable literal type: (define-record-type block-variable-literal @@ -1401,6 +1418,7 @@ ;;; Generation of random names: +;; This one looks iffy. It's also used only in compiler.scm (define (make-random-name . prefix) (string->symbol (sprintf "~A-~A~A" @@ -1416,7 +1434,7 @@ ; -> ; -> or -(define (set-real-name! name rname) +(define (set-real-name! name rname) ; Used only in compiler.scm (##sys#hash-table-set! real-name-table name rname) ) ;; Arbitrary limit to prevent runoff into exponential behavior @@ -1449,17 +1467,18 @@ (else (string-intersperse (reverse nesting) " in "))) ) ) ] [else (##sys#symbol->qualified-string rn)] ) ) ) -(define (real-name2 var db) +(define (real-name2 var db) ; Used only in c-backend.scm (and-let* ([rn (##sys#hash-table-ref real-name-table var)]) (real-name rn db) ) ) -(define (display-real-name-table) +;; TODO: real-name-table is defined in compiler.scm; move it here? +(define (display-real-name-table) ; Used only in batch-driver.scm (##sys#hash-table-for-each (lambda (key val) (printf "~S\t~S~%" key val) ) real-name-table) ) -(define (source-info->string info) +(define (source-info->string info) ; Used only in c-backend.scm (if (list? info) (let ((ln (car info)) (name (cadr info))) @@ -1471,7 +1490,7 @@ (car info) (and info (->string info)))) -(define (call-info params var) +(define (call-info params var) ; Used only in optimizer.scm (or (and-let* ((info (and (pair? (cdr params)) (second params)))) (and (list? info) (let ((ln (car info)) @@ -1482,7 +1501,7 @@ ;;; constant folding support: -(define (constant-form-eval op argnodes k) +(define (constant-form-eval op argnodes k) ; Used only in optimizer.scm (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes)) (form (cons op (map (lambda (arg) `(quote ,arg)) args)))) (handle-exceptions ex @@ -1502,7 +1521,7 @@ ;;; Dump node structure: -(define (dump-nodes n) +(define (dump-nodes n) ; Used only in batch-driver.scm (let loop ([i 0] [n n]) (let ([class (node-class n)] [params (node-parameters n)] @@ -1524,7 +1543,7 @@ ;;; Hook for source information -(define (read-info-hook class data val) +(define (read-info-hook class data val) ; Used here and in compiler.scm (when (and (eq? 'list-info class) (symbol? (car data))) (##sys#hash-table-set! ##sys#line-number-database @@ -1535,7 +1554,7 @@ '() ) ) ) ) data) -(define (read/source-info in) +(define (read/source-info in) ; Used only in batch-driver (##sys#read in read-info-hook) ) @@ -1553,27 +1572,28 @@ (define (scan-sharp-greater-string port) (let ([out (open-output-string)]) (let loop () - (let ([c (read-char port)]) - (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")] - [(char=? c #\newline) + (let ((c (read-char port))) + (cond ((eof-object? c) + (quit-compiling "unexpected end of `#> ... <#' sequence")) + ((char=? c #\newline) (newline out) - (loop) ] - [(char=? c #\<) + (loop) ) + ((char=? c #\<) (let ([c (read-char port)]) (if (eqv? #\# c) (get-output-string out) (begin (write-char #\< out) (write-char c out) - (loop) ) ) ) ] - [else + (loop) ) ) ) ) + (else (write-char c out) - (loop) ] ) ) ) ) ) + (loop) ) ) ) ) ) ) ;;; 64-bit fixnum? -(define (big-fixnum? x) +(define (big-fixnum? x) ;; XXX: This should probably be in c-platform (and (fixnum? x) (##sys#fudge 3) ; 64 bit? (or (fx> x 1073741823) @@ -1582,10 +1602,10 @@ ;;; symbol visibility and other global variable properties -(define (hide-variable sym) +(define (hide-variable sym) ; Used in compiler.scm and here (mark-variable sym '##compiler#visibility 'hidden)) -(define (export-variable sym) +(define (export-variable sym) ; Used only in compiler.scm (mark-variable sym '##compiler#visibility 'exported)) (define (variable-visible? sym) @@ -1595,6 +1615,9 @@ ((exported) #t) (else (not block-compilation))))) +;; These two have somewhat confusing names. Maybe mark-variable could +;; be renamed to "variable-mark-set!"? Also, in some other situations, +;; put!/get are used directly. (define (mark-variable var mark #!optional (val #t)) (##sys#put! var mark val) ) @@ -1602,12 +1625,13 @@ (##sys#get var mark) ) (define intrinsic? (cut variable-mark <> '##compiler#intrinsic)) +;; Used only in optimizer.scm (define foldable? (cut variable-mark <> '##compiler#foldable)) ;;; Load support files -(define (load-identifier-database name) +(define (load-identifier-database name) ; Used only in batch-driver.scm (and-let* ((rp (repository-path)) (dbfile (file-exists? (make-pathname rp name)))) (debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile)) @@ -1622,10 +1646,12 @@ ;;; Print version/usage information: -(define (print-version #!optional b) +(define (print-version #!optional b) ; Used only in batch-driver.scm (when b (print* +banner+)) (print (chicken-version #t)) ) +;; Used only in batch-driver.scm, but it seems to me this should be moved +;; to chicken.scm, as that's the only place this belongs. (define (print-usage) (print-version) (newline) @@ -1753,6 +1779,7 @@ Usage: chicken FILENAME OPTION ... EOF ) ) +;; Same as above (define (print-debug-options) (display #<