~ chicken-core (chicken-5) 50ee93d8db6586e2cda387ed9f86cf62ddb3f8fe
commit 50ee93d8db6586e2cda387ed9f86cf62ddb3f8fe
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 25 19:08:55 2014 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 25 19:08:55 2014 +0200
Squashed commit of the following:
commit 1891eba297ddf6ce8d6012db7e556b3570fe2c7f
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 22:13:56 2014 +0200
compiler-modules: Finalize modularisation of compiler!
Remove compiler-namespace.scm and private-namespace.scm, update NEWS
and remove special-case handling of CHICKEN_COMPILER_OPTIONS from
build system. Add all generated import libraries to distribution
manifest. However, for now they're not compiled to C or installed;
they are only used during generation of the compiler because the
API is nowhere near finished or ready for public consumption. Once
we've defined a "proper" API, these can be compiled and installed too.
commit 9dc927d72c759bb25bfa7090847f3b74427527f5
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 21:50:45 2014 +0200
compiler-modules: Move the remaining globals "unsafe" and "number-type" to support.
These are used in too many places for it to be practical to move them
into the compiler module and pass them around. This should be cleaned
up some day, but not right now.
commit 0cbadaf978dd24e0b904ab62d400e670e2688c79
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 21:05:54 2014 +0200
compiler-modules: Make bindings non-global.
This is a bit of a tricky change. The reason is that the platform
defines the *default* standard, extended, internal and foldable bindings.
The final extended-bindings and standard-bindings, however, are possibly
overridden through declarations by the compiler. The compiler takes the
bindings from the default bindings.
In order to make all this work without creating cyclic dependencies
between the backend/platform and the compiler, we've moved the definitions
of *all* bindings to the compiler. The platform then set!s these to the
correct values. This creates a new dependency between platform and
compiler, but that's okay (the backend also depends on the compiler, and
it exists at about the same level). The compiler-syntax also makes use
of these bindings, so it makes sense to define a dependency for
compiler-syntax on the compiler.
commit 776ef16f7598822f7ae8ac2fd144f98cd8e8ea52
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 20:33:46 2014 +0200
compiler-modules: Move foreign callback code from compiler to support.
Because support makes use of foreign-callback accessors, it makes more
sense to put the record definition there as well. The foreign-type-table
also fits better in support; after moving it there we can put accessors
and setters, as well as an initialization procedure into a "proper" API
which the other modules can consume.
Foreign stubs are now registered through a separate API as well, so that
the foreign stub list can be moved to support. Unfortunately, the
c-backend still accesses this list directly.
commit b98203c1f2ef4e5e5cf8e9658fd1c70031abf1a1
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 17:39:58 2014 +0200
compiler-modules: Reduce coupling between components by passing around more options.
The options in question are used in a lot of places, but it is only
necessary to set them in batch-driver, and export them from compiler.
When invoking a subcomponent of the compiler, batch-driver can pass
the various options to that component. This is inspired by the fact
that the scrutinizer's "scrutinize" procedure already received
"specialize" as an argument. This corresponds to a global
"enable-specialization" option defined in compiler. This idea has
been taken further, with the following options:
- enable-specialization (wasn't passed to load-type-database)
- block-compilation
- inline-locally
- inline-substitutions-enabled
- inline-max-size
- strict-variable-types
commit 63bdf6b8a6c46f192829358c59878c7e38335a77
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 16:51:45 2014 +0200
compiler-modules: Move all profiling support code to support unit.
The declaration of the variables profile-info-vector-name and
profile-lambda-list were moved from compiler to support.
Initialisation of the profiling vector's name has been moved
into a new procedure: reset-profiler-info-vector-name!, which is
exported by support. The code which generates the prelude to
initialise the profiling vector accessed these variables directly,
so to make things a little cleaner this code has been moved to
a single new procedure: profiling-prelude-exps.
There was an unused gensym call in batch-driver, probably originally
used to determine the profile vector's name. This has been removed,
which caused one test to fail due to overly specific reliance on
gensymed names. The scrutiny.expected file has been tweaked accordingly.
commit b432e5c709b539073f4824aa9e12d3e49c565d06
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 16:11:15 2014 +0200
compiler-modules: Fix -no-parentheses-synonyms flag to compiler.
The patch in d31f8ea988425e94745258f174a86fdb2bb06459 was apparently
incomplete: it fixed the interpreter's handling of the
-no-parentheses-synonyms flag, but this flag was not used by the
compiler: it was listed amongst the valid compiler options with
arguments, which is wrong, and the batch-driver used it as a
no-argument flag, but with a typo in its name, so it would never
get used. The version with typo is also used in compiler-namespace.
commit 5a529310b8dd71bc09616c5397615657ad79ec75
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 17 15:53:28 2014 +0200
compiler-modules: Make compiler-arguments and source-file nonglobal by passing them around.
The compiler-arguments global was declared in chicken.scm and used
only in c-backend to write the compiler arguments to the resulting
C file, for informational/debugging/forensic purposes. Just like
the filename and the final (derived) options, this is now passed
around from chicken to batch-driver, and from batch-driver to
c-backend. The variable has been renamed for (hopefully) increased
clarity.
As stated above, the "filename" in batch-driver is passed to some
procedures. However, it is not passed to all: emit-type-file and
emit-global-inline-file were the only two procedures to read the
filename from the global "source-filename". This global has now
been removed and the file name is passed to the procedures as
an argument.
commit a10afa948f68efc5bfa6c7d054c09de078991823
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sat Aug 16 17:45:00 2014 +0200
compiler-modules: Convert compiler to a module.
In eval.scm, there is a hack that invokes ##compiler#process-declaration
when it runs inside the compiler. This has been rewritten to
compiler#process-declaration, which is the modularised new name.
A similar thing was happening for ##sys#do-the-right-thing, where
the hash table ##compiler#file-requirements was updated when running
in the compiler. This has been rewritten to compiler#file-requirements.
Some things have been moved around:
- broken-constant-nodes is moved into optimizer, and not exported
because nobody else is using it.
- compute-database-statistics was moved out of support into compiler,
because it uses a few variables that are internal to compiler and
there's no need to export them. Exporting them would also create a
cyclic dependency between support and compiler, which is not good.
- print-program-statistics was moved out of support into batch-driver
to avoid the cyclic dependency between support and compiler.
It was only used by batch-driver anyway.
- profile-lambda-index has been moved to support, which is the only
place it is used (it's a counter for expand-profile-lambda)
- unlikely-variables has moved from c-platform to compiler, which is
the only place it was used, and it has nothing to do with the
target (C) platform.
- The definition of real-name-table was moved from compiler to support
to avoid cyclic dependencies. To make initialization cleaner,
clear-real-name-table! has been added. Instead of directly looking
up names in the hash-table, compiler now calls get-real-name (which
mirrors the set-real-name! naming convention).
A few obsolete things that were no longer used have been removed:
- csc-control-file
- data-declarations
- require-imports-flag
- postponed-initforms (always empty list, because it is never assigned)
- default-target-heap-size (and the corresponding, no longer used,
C_DEFAULT_TARGET_HEAP_SIZE definition)
Several names were in compiler-namespace that no longer existed, which were
probably dropped somewhere along the line (not in this set of patches):
- debug-info-index
- debug-info-vector-name
- debug-lambda-list
- debug-variable-list
- debugging-executable
- default-default-target-heap-size (typo for default-target-heap-size?)
- default-optimization-iterations (typo for default-optimization-passes?)
- default-output-filename
- dependency-list
- emit-control-file-item
- expand-debug-assignment
- expand-debug-call
- expand-debug-lambda
- expand-foreign-callback-lambda
- expand-foreign-callback-lambda*
- export-dump-hook
- file-io-only
- find-early-refs
- find-inlining-candidates
- foreign-callback-stub-body
- foreign-callback-stub-callback
- foreign-callback-stub-cps
- foreign-string-result-reserve
- foreign-stub-qualifiers
- inlining
- nonwinding-call/cc
- optimization-iterations
- perform-inlining!
- register-unboxed-op
- rest-argument-mode (typo for lambda-literal-rest-argument-mode?)
- rest-parameters-promoted-to-vector
- update-line-number-database (it was probably renamed to have a trailing bang)
commit 95dbd419ed6753fbcadb3f4c1b9b4fdd5287a7a6
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sat Aug 16 17:02:01 2014 +0200
compiler-modules: Simplify compiler module import forms
Prefix the get, get-all, get-list and put! procedures with "db-".
This prevents confusion with the 2-argument "get" and "put!" versions
from library.scm, and it also cleans up the chicken module import.
Remove syntax-error from exclusion list: The module system merely
aliases identifiers, so it doesn't need any special handling in order
to prevent compiler modules from including the "wrong" syntax-error
procedure. Add a test for the aliasing behaviour of the module
system.
The debugging-chicken variable is used in a similar fashion: it is
defined in and exported by support, and it is set! in batch-driver.
It is read by both support and compiler.
commit 28ad796e08682d2e810041444607039fd69e79dd
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 22:03:50 2014 +0200
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.
commit 632045e07adaa0f9d47b3b695e232d5a7b784f6a
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 18:55:12 2014 +0200
compiler-modules: Convert scrutinizer to a module.
In chicken-syntax, :, the, define-specialization, compiler-typecase,
and define-type now expand directly to
scrutinizer#[check-and-]validate-type, which is needed in order to
remove these two procedures from compiler-namespace.
Fixed lfa2 debugging code to look at lfa2-debug instead of
scrutiny-debug. Converted use of string-concatenate to string-join to
avoid dependency on srfi-13, which is slated for extraction from core.
commit f44999c9ead1f6807943371dfdb1e22106bf2b67
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 17:31:54 2014 +0200
compiler-modules: Convert c-backend to a module.
In chicken-ffi-syntax, foreign-type-size now expands directly to
c-backend#foreign-type-declaration, which is needed in order to remove
foreign-type-declaration from compiler-namespace. Added simple test
to ensure that this macro still functions correctly.
Added the variables target-include-file words-per-flonum, parameter-limit
and small-parameter-limit to c-platform's export list. These are
consumed only by c-backend, so can be removed from compiler-namespace.
Added a lot of accessors defined by "compiler" to the compiler-namespace,
which were not renamed correctly before (and, thus, inadvertantly
accessible to user macros when running inside the compiler).
Removed the unused variable unique-id.
commit 1dccfd39cab4d3abbc6e1d262de216129c956001
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 16:46:04 2014 +0200
compiler-modules: Convert c-platform to a module.
A few variables (default-optimization-passes eq-inline-operator,
membership-test-operators and membership-unfold-limit) were defined by
c-platform but used by optimizer. This would result in a circular
dependency, because c-platform is already using various things which
were exported by the optimizer. For this reason, and to reduce
coupling between the optimizer and the platform-specific code,
optimizer now defines the variables, which are then set by the
specific platform in use. This makes it more explicit what the
optimizer needs from a platform.
Removed the unused variable default-debugging-declarations.
Rewrite is now exported cleanly by optimizer, and used by c-platform,
so it could be removed from compiler-namespace.
Added small-parameter-limit to compiler-namespace, for the time being.
commit c3e83850d39f852fa8a03a8d6d44b0c5443f926a
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 15:38:35 2014 +0200
compiler-modules: Convert optimizer to a module
Add "foldable?" to compiler-namespace which would otherwise be
undefined within optimizer (defined in support.scm).
commit bcda11d5cbe80f10b1e60efcb939248ab0c66edf
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 15:27:36 2014 +0200
compiler-modules: Convert compiler-syntax to a module
commit de188037d5535e338dabd3afec89d8be7014b3c6
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 15:17:03 2014 +0200
compiler-modules: Convert lfa2 to a module
Add a few missing names to compiler-namespace which would otherwise be
undefined within lfa2.
commit 1a2be190dfcd0512fba59de6c8a569e384e6fbc1
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 15:00:13 2014 +0200
compiler-modules: Convert batch-driver to a module
For now, we use "batch-driver" as the module name, to make things
simple. Originally, it looks like the idea was that you can have
other kinds of drivers, like an interactive one or a staged one,
or one used through the interpreter. We can try to do this through
the use of functors, perhaps. This makes things simpler for us:
Now we can just append .import.scm to the filename in the build
system. The unit now also has the same name as the module, which
may be undone when we add a functor and an implementation selection
mechanism.
Add a few missing names to compiler-namespace which would otherwise be
undefined within batch-driver.
The apply-test was using "printf" in a macro, which happened to be
available when running inside the compiler due to namespace leakage,
which is now fixed through proper module usage. It now cleanly
imports extras, which provides the printf procedure.
commit c1d87e77993abf4b2835fff140e8c46fcde9b85d
Author: Peter Bex <peter.bex@xs4all.nl>
Date: Sun Aug 10 14:55:01 2014 +0200
compiler-modules: Add normal lookup fallback to private namespace hack
We now remember and call the usual implementation of alias-global-hook
for all variables not part of the namespace hack, so that modules
inside the compiler are supported, but the namespace hack still keeps
working for units not yet converted to a module. Eventually
private-namespace.scm will be removed completely.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/NEWS b/NEWS
index 7a627523..c1a4ab44 100644
--- a/NEWS
+++ b/NEWS
@@ -40,6 +40,9 @@
- Allow functor arguments to be optional, with default implementations.
- Fixed a bug that prevented functors from being instantiated with
built-in modules.
+ - The compiler has been modularised, for improved namespacing. This
+ means names from the compiler should not leak out into the compiled
+ program's (macro) namespace anymore.
- Syntax expander
- define-values, set!-values and letrec-values now support full lambda
@@ -70,6 +73,9 @@
- When using chicken-install -retrieve, and an error occurs during
retrieval (or the egg doesn't exist), the egg's directory is
now properly cleaned up (#1109, thanks to Alex Charlton)
+ - "chicken"
+ - The compiler option -no-parentheses-synonyms has been fixed.
+
4.9.0
diff --git a/batch-driver.scm b/batch-driver.scm
index 9ae5f68a..971218a7 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -24,11 +24,26 @@
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
-
+;; TODO: Rename batch-driver back to "driver" and turn it into a
+;; functor? This may require the creation of an additional file.
+;; Same goes for "backend" and "platform".
(declare
- (unit driver))
+ (unit batch-driver)
+ (uses extras data-structures files srfi-1
+ support compiler-syntax compiler optimizer
+ ;; TODO: Backend should be configurable
+ scrutinizer lfa2 c-platform c-backend) )
+
+(module batch-driver
+ (compile-source-file
+
+ user-options-pass user-read-pass user-preprocessor-pass user-pass
+ user-post-analysis-pass)
+
+(import chicken scheme extras data-structures files srfi-1
+ support compiler-syntax compiler optimizer scrutinizer lfa2
+ c-platform c-backend)
-(include "compiler-namespace")
(include "tweaks")
(define-constant funny-message-timeout 60000)
@@ -39,16 +54,121 @@
(define user-pass (make-parameter #f))
(define user-post-analysis-pass (make-parameter #f))
+;;; Emit collected information from various statistics about the program
+
+(define (print-program-statistics db)
+ (receive
+ (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
+ (when (debugging 's "program statistics:")
+ (printf "; program size: \t~s \toriginal program size: \t~s\n" size osize)
+ (printf "; variables with known values: \t~s\n" kvars)
+ (printf "; known procedures: \t~s\n" kprocs)
+ (printf "; global variables: \t~s\n" globs)
+ (printf "; known call sites: \t~s\n" sites)
+ (printf "; database entries: \t~s\n" entries) ) ) )
+
+;;; Initialize analysis database:
+;;
+;; - Simply marks the symbols directly in the plist.
+;; - Does nothing after the first invocation, but we leave it this way to
+;; have the option to add default entries for each new db.
+
+(define initialize-analysis-database
+ (let ((initial #t))
+ (lambda ()
+ (when initial
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'standard)
+ (when (memq s foldable-bindings)
+ (mark-variable s '##compiler#foldable #t)))
+ standard-bindings)
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'extended)
+ (when (memq s foldable-bindings)
+ (mark-variable s '##compiler#foldable #t)))
+ extended-bindings)
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'internal))
+ internal-bindings))
+ (set! initial #f))))
+
+;;; Display analysis database:
+
+(define display-analysis-database
+ (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
+ (assigned-locally . stl)
+ (contractable . con) (standard-binding . stb) (simple . sim)
+ (inlinable . inl)
+ (collapsable . col) (removable . rem) (constant . con)
+ (inline-target . ilt) (inline-transient . itr)
+ (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
+ (inline-export . ilx) (hidden-refs . hrf)
+ (value-ref . vvf)
+ (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
+ (omit #f))
+ (lambda (db)
+ (unless omit
+ (set! omit
+ (append default-standard-bindings
+ default-extended-bindings
+ internal-bindings) ) )
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (let ([val #f]
+ (lval #f)
+ [pval #f]
+ [csites '()]
+ [refs '()] )
+ (unless (memq sym omit)
+ (write sym)
+ (let loop ((es plist))
+ (if (pair? es)
+ (begin
+ (case (caar es)
+ ((captured assigned boxed global contractable standard-binding assigned-locally
+ collapsable removable undefined replacing unused simple inlinable inline-export
+ has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
+ (printf "\t~a" (cdr (assq (caar es) names))) )
+ ((unknown)
+ (set! val 'unknown) )
+ ((value)
+ (unless (eq? val 'unknown) (set! val (cdar es))) )
+ ((local-value)
+ (unless (eq? val 'unknown) (set! lval (cdar es))) )
+ ((potential-value)
+ (set! pval (cdar es)) )
+ ((replacable home contains contained-in use-expr closure-size rest-parameter
+ captured-variables explicit-rest)
+ (printf "\t~a=~s" (caar es) (cdar es)) )
+ ((references)
+ (set! refs (cdar es)) )
+ ((call-sites)
+ (set! csites (cdar es)) )
+ (else (bomb "Illegal property" (car es))) )
+ (loop (cdr es)) ) ) )
+ (cond [(and val (not (eq? val 'unknown)))
+ (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
+ [(and lval (not (eq? val 'unknown)))
+ (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
+ [(and pval (not (eq? val 'unknown)))
+ (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
+ (when (pair? refs) (printf "\trefs=~s" (length refs)))
+ (when (pair? csites) (printf "\tcss=~s" (length csites)))
+ (newline) ) ) )
+ db) ) ) )
;;; Compile a complete source file:
-(define (compile-source-file filename . options)
+(define (compile-source-file filename user-suppplied-options . 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))
@@ -71,7 +191,7 @@
(string-split
(or (get-environment-variable "CHICKEN_INCLUDE_PATH") "")
";")))
- (opasses default-optimization-passes)
+ (opasses (default-optimization-passes))
(time0 #f)
(time-breakdown #f)
(forms '())
@@ -138,7 +258,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])
@@ -159,8 +279,8 @@
(let ((db (analyze-expression node)))
(when upap
(upap pass db node
- (cut get db <> <>)
- (cut put! db <> <> <>)
+ (cut db-get db <> <>)
+ (cut db-put! db <> <> <>)
no contf) )
db) ) )
@@ -244,7 +364,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)
@@ -254,10 +375,11 @@
(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")] ) ) )
- (when (memq 'no-parenthesis-synonyms options)
- (dribble "Disabled support for parenthesis synonyms")
- (parenthesis-synonyms #f) )
+ [else (quit-compiling
+ "invalid argument to `-keyword-style' option")] ) ) )
+ (when (memq 'no-parentheses-synonyms options)
+ (dribble "Disabled support for parentheses synonyms")
+ (parentheses-synonyms #f) )
(when (memq 'no-symbol-escape options)
(dribble "Disabled support for escaped symbols")
(symbol-escape #f) )
@@ -274,7 +396,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 ", ")))
@@ -321,9 +443,6 @@
(set! ##sys#features (cons '#:compiling ##sys#features))
(set! upap (user-post-analysis-pass))
- ;; Insert postponed initforms:
- (set! initforms (append initforms postponed-initforms))
-
;; Append required extensions to initforms:
(set! initforms
(append
@@ -355,7 +474,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)
@@ -388,7 +507,6 @@
;; Display header:
(dribble "compiling `~a' ..." filename)
- (set! source-filename filename)
(debugging 'r "options" options)
(debugging 'r "debugging options" debugging-chicken)
(debugging 'r "target heap size" target-heap-size)
@@ -446,29 +564,18 @@
(import scheme chicken)
,@forms))
forms))))
- [pvec (gensym)]
- [plen (length profile-lambda-list)]
- [exps (append
+ (exps (append
(map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
(map (lambda (n) `(##core#callunit ,n)) used-units)
(if emit-profile
- `((set! ,profile-info-vector-name
- (##sys#register-profile-info
- ',plen
- ',(and (not unit-name)
- (or profile-name #t)))))
+ (profiling-prelude-exps (and (not unit-name)
+ (or profile-name #t)))
'() )
- (map (lambda (pl)
- `(##sys#set-profile-info-vector!
- ,profile-info-vector-name
- ',(car pl)
- ',(cdr pl) ) )
- profile-lambda-list)
exps0
(if (and (not unit-name) (not dynamic))
cleanup-forms
'() )
- '((##core#undefined))) ] )
+ '((##core#undefined))) ) )
(when (pair? compiler-syntax-statistics)
(with-debugging-output
@@ -539,16 +646,20 @@
(when (or do-scrutinize enable-specialization)
;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
- (unless (load-type-database "types.db")
- (quit "default type-database `types.db' not found")))
+ (unless (load-type-database "types.db"
+ enable-specialization)
+ (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)))
+ (or (load-type-database fn enable-specialization #f)
+ (quit-compiling "type-database `~a' not found" fn)))
(collect-options 'types))
(for-each
(lambda (id)
- (load-type-database (make-pathname #f (symbol->string id) "types")))
+ (load-type-database
+ (make-pathname #f (symbol->string id) "types")
+ enable-specialization))
mreq)
(begin-time)
(set! first-analysis #f)
@@ -557,12 +668,15 @@
(end-time "pre-analysis (scrutiny)")
(begin-time)
(debugging 'p "performing scrutiny")
- (scrutinize node0 db do-scrutinize enable-specialization)
+ (scrutinize node0 db
+ do-scrutinize enable-specialization
+ strict-variable-types block-compilation)
(end-time "scrutiny")
(when enable-specialization
(print-node "specialization" '|P| node0))
(set! first-analysis #t) ) )
+ ;; TODO: Move this so that we don't need to export these
(set! ##sys#line-number-database #f)
(set! constant-table #f)
(set! inline-table #f)
@@ -595,7 +709,7 @@
;; do this here, because we must make sure we have a db
(when type-output-file
(dribble "generating type file `~a' ..." type-output-file)
- (emit-type-file type-output-file db)))
+ (emit-type-file filename type-output-file db block-compilation)))
(set! first-analysis #f)
(end-time "analysis")
(print-db "analysis" '|4| db i)
@@ -610,7 +724,10 @@
(receive (node2 progress-flag)
(if l/d
(determine-loop-and-dispatch node2 db)
- (perform-high-level-optimizations node2 db))
+ (perform-high-level-optimizations
+ node2 db block-compilation
+ inline-locally inline-max-size
+ inline-substitutions-enabled))
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
(cond (progress-flag
@@ -651,7 +768,9 @@
(when (and inline-output-file insert-timer-checks)
(let ((f inline-output-file))
(dribble "generating global inline file `~a' ..." f)
- (emit-global-inline-file f db) ) )
+ (emit-global-inline-file
+ filename f db block-compilation
+ inline-max-size) ) )
(begin-time)
;; Closure conversion
(set! node2 (perform-closure-conversion node2 db))
@@ -672,7 +791,7 @@
;; Code generation
(let ((out (if outfile (open-output-file outfile) (current-output-port))) )
(dribble "generating `~A' ..." outfile)
- (generate-code literals lliterals lambda-table out filename dynamic db)
+ (generate-code literals lliterals lambda-table out filename user-suppplied-options dynamic db)
(when outfile
(close-output-port out)))
(end-time "code generation")
@@ -680,3 +799,4 @@
(##sys#display-times (##sys#stop-timer)))
(compiler-cleanup-hook)
(dribble "compilation finished.") ) ) ) ) ) ) ) ) ) ) ) )
+)
\ No newline at end of file
diff --git a/c-backend.scm b/c-backend.scm
index eade651d..b5233023 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -25,12 +25,21 @@
; POSSIBILITY OF SUCH DAMAGE.
-(declare (unit backend))
-
-
-(include "compiler-namespace")
-(include "tweaks")
-
+;; TODO: Rename c-backend back to "backend" and turn it into a
+;; functor? This may require the creation of an additional file.
+;; Same goes for "platform" and "driver".
+(declare
+ (unit c-backend)
+ (uses srfi-1 data-structures
+ c-platform compiler support))
+
+(module c-backend
+ (generate-code
+ ;; For "foreign" (aka chicken-ffi-syntax):
+ foreign-type-declaration)
+
+(import chicken scheme foreign srfi-1 data-structures
+ compiler c-platform support)
;;; Write atoms to output-port:
@@ -49,17 +58,14 @@
(lambda (x) (display x output))
(intersperse lst #\space) ) )
-
-;;; Unique id/prefix:
-
-(define unique-id
- (string->c-identifier
- (sprintf "C_~X_~A_" (random #x1000000) (current-seconds)) ) )
-
+;; 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)
+(define (generate-code literals lliterals lambda-table out source-file user-supplied-options dynamic db)
;; Don't truncate floating-point precision!
(flonum-print-precision (+ flonum-maximum-decimal-exponent 1))
(let ()
@@ -477,7 +483,7 @@
(string-split (chicken-version #t) "\n") )
"")
" command line: ")
- (gen-list compiler-arguments)
+ (gen-list user-supplied-options)
(gen #t)
(cond [unit-name (gen " unit: " unit-name)]
[else
@@ -679,7 +685,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)])
@@ -1075,41 +1081,40 @@
(define (generate-foreign-callback-stubs stubs db)
(for-each
(lambda (stub)
- (let* ([id (foreign-callback-stub-id stub)]
- [rname (real-name2 id db)]
- [rtype (foreign-callback-stub-return-type stub)]
- [argtypes (foreign-callback-stub-argument-types stub)]
- [n (length argtypes)]
- [vlist (make-argument-list n "t")] )
+ (let* ((id (foreign-callback-stub-id stub))
+ (rname (real-name2 id db))
+ (rtype (foreign-callback-stub-return-type stub))
+ (argtypes (foreign-callback-stub-argument-types stub))
+ (n (length argtypes))
+ (vlist (make-argument-list n "t")) )
(define (compute-size type var ns)
(case type
- [(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
+ ((char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
byte unsigned-byte)
- ns]
- [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32
+ ns)
+ ((float double c-pointer unsigned-integer unsigned-integer32 long integer integer32
unsigned-long size_t
nonnull-c-pointer number unsigned-integer64 integer64 c-string-list
c-string-list*)
- (string-append ns "+3") ]
- [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
- (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
- [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
- (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ]
- [else
- (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
- => (lambda (t)
- (compute-size (if (vector? t) (vector-ref t 0) t) var ns) ) ]
- [(pair? type)
+ (string-append ns "+3") )
+ ((c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
+ (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") )
+ ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
+ (string-append ns "+2+C_bytestowords(C_strlen(" var "))") )
+ (else
+ (cond ((and (symbol? type) (lookup-foreign-type type))
+ => (lambda (t) (compute-size (vector-ref t 0) var ns) ) )
+ ((pair? type)
(case (car type)
- [(ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance
+ ((ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance
nonnull-instance instance-ref)
- (string-append ns "+3") ]
- [(const) (compute-size (cadr type) var ns)]
- [else ns] ) ]
- [else ns] ) ] ) )
+ (string-append ns "+3") )
+ ((const) (compute-size (cadr type) var ns))
+ (else ns) ) )
+ (else ns) ) ) ) )
- (let ([sizestr (fold compute-size "0" argtypes vlist)])
+ (let ((sizestr (fold compute-size "0" argtypes vlist)))
(gen #t)
(when rname
(gen #t "/* from " (cleanup rname) " */") )
@@ -1131,12 +1136,12 @@
stubs) )
(define (generate-foreign-callback-header cls stub)
- (let* ([name (foreign-callback-stub-name stub)]
- [quals (foreign-callback-stub-qualifiers stub)]
- [rtype (foreign-callback-stub-return-type stub)]
- [argtypes (foreign-callback-stub-argument-types stub)]
- [n (length argtypes)]
- [vlist (make-argument-list n "t")] )
+ (let* ((name (foreign-callback-stub-name stub))
+ (quals (foreign-callback-stub-qualifiers stub))
+ (rtype (foreign-callback-stub-return-type stub))
+ (argtypes (foreign-callback-stub-argument-types stub))
+ (n (length argtypes))
+ (vlist (make-argument-list n "t")) )
(gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()
(pair-for-each
(lambda (vs ts)
@@ -1149,47 +1154,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) (lookup-foreign-type type))
=> (lambda (t)
- (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
- [(string? type) (str type)]
- [(list? type)
+ (foreign-type-declaration (vector-ref t 0) target)) )
+ ((string? type) (str type))
+ ((list? type)
(let ((len (length type)))
(cond
((and (= 2 len)
@@ -1238,14 +1243,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)")
@@ -1289,33 +1295,34 @@
nonnull-unsigned-c-string* symbol) "C_c_string(")
((bool) "C_truep(")
(else
- (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ (cond ((and (symbol? type) (lookup-foreign-type type))
=> (lambda (t)
- (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ]
- [(and (list? type) (>= (length type) 2))
+ (foreign-argument-conversion (vector-ref t 0)) ) )
+ ((and (list? type) (>= (length type) 2))
(case (car type)
- ((c-pointer) "C_c_pointer_or_null(")
- ((nonnull-c-pointer) "C_c_pointer_nn(")
- ((instance) "C_c_pointer_or_null(")
- ((nonnull-instance) "C_c_pointer_nn(")
- ((scheme-pointer) "C_data_pointer_or_null(")
- ((nonnull-scheme-pointer) "C_data_pointer(")
- ((function) "C_c_pointer_or_null(")
- ((const) (foreign-argument-conversion (cadr type)))
- ((enum) "C_num_to_int(")
- ((ref)
- (string-append "*(" (foreign-type-declaration (cadr type) "*")
- ")C_c_pointer_nn("))
- ((instance-ref)
- (string-append "*(" (cadr type) "*)C_c_pointer_nn("))
- (else (err)) ) ]
- [else (err)] ) ) ) ) )
+ ((c-pointer) "C_c_pointer_or_null(")
+ ((nonnull-c-pointer) "C_c_pointer_nn(")
+ ((instance) "C_c_pointer_or_null(")
+ ((nonnull-instance) "C_c_pointer_nn(")
+ ((scheme-pointer) "C_data_pointer_or_null(")
+ ((nonnull-scheme-pointer) "C_data_pointer(")
+ ((function) "C_c_pointer_or_null(")
+ ((const) (foreign-argument-conversion (cadr type)))
+ ((enum) "C_num_to_int(")
+ ((ref)
+ (string-append "*(" (foreign-type-declaration (cadr type) "*")
+ ")C_c_pointer_nn("))
+ ((instance-ref)
+ (string-append "*(" (cadr type) "*)C_c_pointer_nn("))
+ (else (err)) ) )
+ (else (err)) ) ) ) ) )
;; 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)")
@@ -1340,10 +1347,10 @@
((bool) "C_mk_bool(")
((void scheme-object) "((C_word)")
(else
- (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ (cond ((and (symbol? type) (lookup-foreign-type type))
=> (lambda (x)
- (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ]
- [(and (list? type) (>= (length type) 2))
+ (foreign-result-conversion (vector-ref x 0) dest)) )
+ ((and (list? type) (>= (length type) 2))
(case (car type)
((nonnull-pointer nonnull-c-pointer)
(sprintf "C_mpointer(&~A,(void*)" dest) )
@@ -1360,8 +1367,8 @@
(sprintf "C_mpointer_or_false(&~a,(void*)" dest) )
((function) (sprintf "C_mpointer(&~a,(void*)" dest))
((enum) (sprintf "C_int_to_num(&~a," dest))
- (else (err)) ) ]
- [else (err)] ) ) ) ) )
+ (else (err)) ) )
+ (else (err)) ) ) ) ) )
;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
@@ -1428,3 +1435,4 @@ return((C_header_bits(lit) >> 24) & 0xff);
(encode-size len)
(list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
""))))) )
+)
\ No newline at end of file
diff --git a/c-platform.scm b/c-platform.scm
index 1d60dcd1..f9fea6bb 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -25,16 +25,32 @@
; POSSIBILITY OF SUCH DAMAGE.
-(declare (unit platform))
+;; TODO: Rename c-platform back to "platform" and turn it into a
+;; functor? This may require the creation of an additional file.
+;; Same goes for "backend" and "driver".
+(declare
+ (unit c-platform)
+ (uses srfi-1 data-structures
+ optimizer support compiler))
+
+(module c-platform
+ (default-declarations default-profiling-declarations
+ units-used-by-default
+ valid-compiler-options valid-compiler-options-with-argument
+
+ ;; For consumption by c-backend *only*
+ target-include-file words-per-flonum
+ parameter-limit small-parameter-limit)
+
+(import chicken scheme srfi-1 data-structures
+ optimizer support compiler)
-
-(include "compiler-namespace")
(include "tweaks")
;;; Parameters:
-(define default-optimization-passes 3)
+(default-optimization-passes 3)
(define default-declarations
'((always-bound
@@ -51,30 +67,22 @@
##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
##sys#call-with-current-continuation) ) )
-(define default-debugging-declarations
- '((##core#declare
- '(uses debugger)
- '(bound-to-procedure
- ##sys#push-debug-frame ##sys#pop-debug-frame ##sys#check-debug-entry ##sys#check-debug-assignment
- ##sys#register-debug-lambdas ##sys#register-debug-variables ##sys#debug-call) ) ) )
-
(define default-profiling-declarations
'((##core#declare
(uses profiler)
(bound-to-procedure
##sys#profile-entry ##sys#profile-exit) ) ) )
-(define units-used-by-default '(library eval chicken-syntax))
+(define units-used-by-default '(library eval chicken-syntax))
(define words-per-flonum 4)
(define parameter-limit 1024)
(define small-parameter-limit 128)
-(define unlikely-variables '(unquote unquote-splicing))
-(define eq-inline-operator "C_eqp")
-(define membership-test-operators
+(eq-inline-operator "C_eqp")
+(membership-test-operators
'(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
("C_i_memv" . "C_i_eqvp") ) )
-(define membership-unfold-limit 20)
+(membership-unfold-limit 20)
(define target-include-file "chicken.h")
(define valid-compiler-options
@@ -89,7 +97,7 @@
emit-external-prototypes-first release local inline-global
analyze-only dynamic
scrutinize ; OBSOLETE
- no-argc-checks no-procedure-checks
+ no-argc-checks no-procedure-checks no-parentheses-synonyms
no-procedure-checks-for-toplevel-bindings module
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
@@ -100,7 +108,6 @@
'(debug
output-file include-path heap-size stack-size unit uses keyword-style require-extension
inline-limit profile-name
- parenthesis-synonyms
prelude postlude prologue epilogue nursery extend feature no-feature types
emit-import-library emit-inline-file static-extension consult-inline-file
emit-type-file
@@ -109,7 +116,7 @@
;;; Standard and extended bindings:
-(define default-standard-bindings
+(set! default-standard-bindings
'(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
@@ -130,7 +137,7 @@
list-ref abs char-ready? peek-char list->string string->list
current-input-port current-output-port) )
-(define default-extended-bindings
+(set! default-extended-bindings
'(bitwise-and alist-cons xcons
bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/
fx+? fx-? fx*? fx/? fxmod o fp/?
@@ -166,7 +173,7 @@
current-error-port current-thread
printf sprintf format fprintf get-keyword) )
-(define internal-bindings
+(set! internal-bindings
'(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
@@ -220,7 +227,7 @@
pointer-f32-ref pointer-f32-set!
pointer-f64-ref pointer-f64-set!))
-(define foldable-bindings
+(set! foldable-bindings
(lset-difference
eq?
(lset-union eq? default-standard-bindings default-extended-bindings)
@@ -470,22 +477,22 @@
(and (= (length callargs) 1)
(call-with-current-continuation
(lambda (return)
- (let ([arg (first callargs)])
+ (let ((arg (first callargs)))
(make-node
'##core#call (list #t)
(list
cont
- (cond [(and (eq? '##core#variable (node-class arg))
- (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) )
+ (cond ((and (eq? '##core#variable (node-class arg))
+ (eq? 'vector (db-get db (first (node-parameters arg)) 'rest-parameter)) )
(make-node
'##core#inline
(if unsafe
'("C_slot")
'("C_i_vector_ref") )
- (list arg (qnode index)) ) ]
- [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]
- [iop1 (make-node '##core#inline (list iop1) callargs)]
- [else (return #f)] ) ) ) ) ) ) ) ) ) )
+ (list arg (qnode index)) ) )
+ ((and unsafe iop2) (make-node '##core#inline (list iop2) callargs))
+ (iop1 (make-node '##core#inline (list iop1) callargs))
+ (else (return #f)) ) ) ) ) ) ) ) ) ) )
(rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
(rewrite-c..r '##sys#car "C_i_car" "C_u_i_car" 0)
@@ -516,7 +523,7 @@
(and (eq? '##core#variable (node-class arg1)) ; probably not needed
(eq? '##core#variable (node-class arg2))
(and-let* ((sym (car (node-parameters arg2)))
- (val (get db sym 'value)) )
+ (val (db-get db sym 'value)) )
(and (eq? '##core#lambda (node-class val))
(let ((llist (third (node-parameters val))))
(and (proper-list? llist)
@@ -1066,19 +1073,19 @@
(define (rewrite-call/cc db classargs cont callargs)
;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)
(and (= 1 (length callargs))
- (let ([val (first callargs)])
+ (let ((val (first callargs)))
(and (eq? '##core#variable (node-class val))
- (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
+ (and-let* ((proc (db-get db (first (node-parameters val)) 'value))
+ ((eq? '##core#lambda (node-class proc))) )
+ (let ((llist (third (node-parameters proc))))
+ (##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
(and (= argc 2)
- (let ([var (or rest (second llist))])
- (and (not (get db var 'references))
- (not (get db var 'assigned))
- (not (get db var 'inline-transient))
+ (let ((var (or rest (second llist))))
+ (and (not (db-get db var 'references))
+ (not (db-get db var 'assigned))
+ (not (db-get db var 'inline-transient))
(make-node
'##core#call (list #t)
(list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
@@ -1142,7 +1149,7 @@
'##core#call (list #t)
(list cont
(if (and (eq? '##core#variable (node-class arg))
- (not (get db (car (node-parameters arg)) 'global)) )
+ (not (db-get db (car (node-parameters arg)) 'global)) )
(qnode #t)
(make-node
'##core#inline '("C_anyp")
@@ -1203,3 +1210,4 @@
'##core#inline_allocate
'("C_a_i_cons" 3)
(list (second callargs) (varnode tmp)))))))))))
+)
\ No newline at end of file
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index d07764f6..0e749f56 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -28,7 +28,10 @@
(declare
(unit chicken-ffi-syntax)
(disable-interrupts)
- (fixnum) )
+ (fixnum))
+
+;; IMPORTANT: These macros expand directly into fully qualified names
+;; from the "c-backend" and "support" modules.
#+(not debugbuild)
(declare
@@ -38,7 +41,6 @@
(##sys#provide
'chicken-ffi-syntax)
-
(define ##sys#chicken-ffi-macro-environment
(let ((me0 (##sys#macro-environment)))
@@ -171,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) ) ) ) ) )
@@ -215,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)))))))
@@ -227,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))))))
@@ -241,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))))))
@@ -255,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))))))
@@ -269,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))))))
@@ -287,7 +289,8 @@
(decl
(if (string? t)
t
- (##compiler#foreign-type-declaration t ""))))
+ ;; TODO: Backend should be configurable
+ (c-backend#foreign-type-declaration t ""))))
`(##core#begin
(##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))
(##core#the fixnum #f ,tmp))))))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index edc42ec8..35335be3 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -30,6 +30,9 @@
(disable-interrupts)
(fixnum) )
+;; IMPORTANT: These macros expand directly into fully qualified names
+;; from the scrutinizer and support modules.
+
#+(not debugbuild)
(declare
(no-bound-checks)
@@ -1174,9 +1177,9 @@
'(##core#undefined)
(let* ((type1 (##sys#strip-syntax (caddr x)))
(name1 (cadr x)))
- ;; we need pred/pure info, so not using "##compiler#check-and-validate-type"
+ ;; we need pred/pure info, so not using "scrutinizer#check-and-validate-type"
(let-values (((type pred pure)
- (##compiler#validate-type type1 (##sys#strip-syntax name1))))
+ (scrutinizer#validate-type type1 (##sys#strip-syntax name1))))
(cond ((not type)
(syntax-error ': "invalid type syntax" name1 type1))
(else
@@ -1192,7 +1195,7 @@
(##sys#check-syntax 'the x '(_ _ _))
(if (not (memq #:compiling ##sys#features))
(caddr x)
- `(##core#the ,(##compiler#check-and-validate-type (cadr x) 'the)
+ `(##core#the ,(scrutinizer#check-and-validate-type (cadr x) 'the)
#t
,(caddr x))))))
@@ -1235,13 +1238,13 @@
(cons atypes
(if (and rtypes (pair? rtypes))
(list
- (map (cut ##compiler#check-and-validate-type
+ (map (cut scrutinizer#check-and-validate-type
<>
'define-specialization)
rtypes)
spec)
(list spec))))
- (or (##compiler#variable-mark
+ (or (support#variable-mark
gname
'##compiler#local-specializations)
'())))
@@ -1261,7 +1264,7 @@
(cdr args)
(cons (car arg) anames)
(cons
- (##compiler#check-and-validate-type
+ (scrutinizer#check-and-validate-type
(cadr arg)
'define-specialization)
atypes)))
@@ -1287,7 +1290,7 @@
(if (eq? hd 'else)
'else
(if val
- (##compiler#check-and-validate-type
+ (scrutinizer#check-and-validate-type
hd
'compiler-typecase)
hd))
@@ -1308,7 +1311,7 @@
(##sys#put/restore!
(,%quote ,name)
(,%quote ##compiler#type-abbreviation)
- (,%quote ,(##compiler#check-and-validate-type t0 'define-type name))))))))))
+ (,%quote ,(scrutinizer#check-and-validate-type t0 'define-type name))))))))))
;; capture current macro env
diff --git a/chicken.scm b/chicken.scm
index 3e0343a0..5e85efdd 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -28,13 +28,14 @@
(declare
(uses chicken-syntax chicken-ffi-syntax
srfi-1 srfi-4 utils files extras data-structures support
- compiler optimizer lfa2 compiler-syntax scrutinizer driver platform backend
+ compiler optimizer lfa2 compiler-syntax scrutinizer
+ ;; TODO: These three need to be made configurable somehow
+ batch-driver c-platform c-backend
srfi-69))
-(include "compiler-namespace")
(include "tweaks")
-
+(import batch-driver c-platform)
;;; Prefix argument list with default options:
@@ -71,6 +72,7 @@
;;; Run compiler with command-line options:
(receive (filename options) ((or (user-options-pass) process-command-line) compiler-arguments)
+ ;; TODO: Perhaps option parsing should be moved to batch-driver?
(let loop ((os options))
(unless (null? os)
(let ((o (car os))
@@ -142,11 +144,11 @@
((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)"
(if (string? o) o (conc "-" o)) )
(loop rest) ) ) ) ) )
- (apply compile-source-file filename options)
+ (apply compile-source-file filename compiler-arguments options)
(exit) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
deleted file mode 100644
index 7af9593f..00000000
--- a/compiler-namespace.scm
+++ /dev/null
@@ -1,309 +0,0 @@
-;;;; compiler-namespace.scm - private namespace declarations for compiler units
-;
-; Copyright (c) 2009-2014, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(private
- 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-list-type
- canonicalize-begin-body
- canonicalize-expression
- check-and-open-input-file
- check-and-validate-type
- check-signature
- chop-extension
- chop-separator
- cleanup
- close-checked-input-file
- collapsable-literal?
- collect!
- collected-debugging-output
- compile-format-string
- compiler-arguments
- compiler-cleanup-hook
- compiler-source-file
- compiler-syntax-enabled
- compiler-syntax-statistics
- 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
- data-declarations
- debug-info-index
- debug-info-vector-name
- debug-lambda-list
- debug-variable-list
- debugging
- debugging-chicken
- debugging-executable
- determine-loop-and-dispatch
- decompose-lambda-list
- default-debugging-declarations
- default-declarations
- default-default-target-heap-size
- default-extended-bindings
- default-optimization-iterations
- default-optimization-passes
- default-optimization-passes-when-trying-harder
- default-output-filename
- default-profiling-declarations
- default-standard-bindings
- defconstant-bindings
- 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
- emit-type-file
- enable-inline-files
- enable-specialization
- encode-literal
- eq-inline-operator
- estimate-foreign-result-location-size
- estimate-foreign-result-size
- expand-debug-assignment
- expand-debug-call
- expand-debug-lambda
- expand-foreign-callback-lambda
- expand-foreign-callback-lambda*
- expand-foreign-lambda
- expand-foreign-lambda*
- expand-foreign-primitive
- expand-profile-lambda
- explicit-use-flag
- export-dump-hook
- export-variable
- expression-has-side-effects?
- 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-bindings
- follow-without-loop
- foreign-argument-conversion
- foreign-declarations
- foreign-lambda-stubs
- foreign-result-conversion
- foreign-string-result-reserve
- foreign-type->scrutiny-type
- foreign-type-check
- foreign-type-convert-argument
- foreign-type-convert-result
- foreign-type-declaration
- foreign-type-table
- foreign-variables
- gen
- gen-list
- generate-code
- generate-external-variables
- generate-foreign-callback-header
- generate-foreign-callback-stub-prototypes
- generate-foreign-stubs
- 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
- inline-table
- inline-table-used
- inlining
- insert-timer-checks
- install-specializations
- installation-home
- internal-bindings
- intrinsic?
- line-number-database-2
- line-number-database-size
- llist-length
- llist-match?
- load-identifier-database
- load-inline-file
- load-type-database
- local-definitions
- location-pointer-map
- make-argument-list
- make-block-variable-literal
- make-random-name
- make-variable-list
- mark-variable
- match-node
- membership-test-operators
- membership-unfold-limit
- no-argc-checks
- no-bound-checks
- no-global-procedure-checks
- enable-module-registration
- no-procedure-checks
- node->sexpr
- non-foldable-bindings
- nonwinding-call/cc
- optimization-iterations
- original-program-size
- output
- parameter-limit
- pending-canonicalizations
- perform-closure-conversion
- perform-cps-conversion
- perform-high-level-optimizations
- perform-inlining!
- perform-pre-optimization!
- perform-secondary-flow-analysis
- 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
- r-c-s
- read/source-info
- real-name
- real-name-table
- real-name2
- register-unboxed-op
- reorganize-recursive-bindings
- require-imports-flag
- rest-parameters-promoted-to-vector
- rewrite
- safe-globals-flag
- scan-free-variables
- scan-sharp-greater-string
- scan-toplevel-assignments
- scan-used-variables
- scrutinize
- scrutiny-debug
- set-real-name!
- sexpr->node
- simple-lambda-node?
- simplifications
- simplified-ops
- simplify-named-call
- simplify-type
- slashify
- sort-symbols
- source-filename
- source-info->string
- source-info->line
- specialize-node!
- standalone-executable
- strict-variable-types
- string->c-identifier
- string->expr
- stringify
- substitution-table
- symbolify
- target-heap-size
- target-include-file
- target-stack-size
- toplevel-lambda-id
- toplevel-scope
- transform-direct-lambdas!
- tree-copy
- uncommentify
- undefine-shadowed-macros
- unique-id
- unit-name
- units-used-by-default
- unlikely-variables
- update-line-number-database
- update-line-number-database!
- used-units
- valid-c-identifier?
- valid-compiler-options
- valid-compiler-options-with-argument
- validate-type
- variable-mark
- variable-visible?
- varnode
- verbose-mode
- with-debugging-output
- words
- words->bytes
- words-per-flonum)
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index db28e68e..9fed04ca 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -25,10 +25,16 @@
(declare
- (unit compiler-syntax) )
+ (unit compiler-syntax)
+ (uses srfi-1 data-structures
+ support compiler) )
+(module compiler-syntax
+ (compiler-syntax-statistics)
+
+(import chicken scheme srfi-1 data-structures
+ support compiler)
-(include "compiler-namespace")
(include "tweaks.scm")
@@ -312,3 +318,4 @@
(,f ,zvar (##sys#slot ,lstvar 0)))
,zvar))))
x))
+)
\ No newline at end of file
diff --git a/compiler.scm b/compiler.scm
index 17594588..88a5ee57 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -263,10 +263,60 @@
(declare
- (unit compiler))
-
-
-(include "compiler-namespace")
+ (unit compiler)
+ (uses srfi-1 extras data-structures
+ scrutinizer support) )
+
+(module compiler
+ (analyze-expression canonicalize-expression compute-database-statistics
+ initialize-compiler perform-closure-conversion perform-cps-conversion
+ prepare-for-code-generation
+
+ ;; These are both exported for use in eval.scm (which is a bit of
+ ;; a hack). file-requirements is also used by batch-driver
+ process-declaration file-requirements
+
+ ;; Various ugly global boolean flags that get set by the (batch) driver
+ all-import-libraries bootstrap-mode compiler-syntax-enabled
+ emit-closure-info emit-profile enable-inline-files explicit-use-flag
+ first-analysis no-bound-checks enable-module-registration
+ optimize-leaf-routines standalone-executable undefine-shadowed-macros
+ verbose-mode local-definitions enable-specialization block-compilation
+ inline-locally inline-substitutions-enabled strict-variable-types
+
+ ;; These are set by the (batch) driver, and read by the (c) backend
+ disable-stack-overflow-checking emit-trace-info external-protos-first
+ external-variables insert-timer-checks no-argc-checks
+ no-global-procedure-checks no-procedure-checks
+
+ ;; Other, non-boolean, flags set by (batch) driver
+ profiled-procedures import-libraries inline-max-size
+ extended-bindings standard-bindings
+
+ ;; non-booleans set by the (batch) driver, and read by the (c) backend
+ target-heap-size target-stack-size unit-name used-units
+
+ ;; bindings, set by the (c) platform
+ default-extended-bindings default-standard-bindings
+ internal-bindings foldable-bindings
+
+ ;; Only read or called by the (c) backend
+ foreign-declarations foreign-lambda-stubs foreign-stub-argument-types
+ foreign-stub-argument-names foreign-stub-body foreign-stub-callback
+ foreign-stub-cps foreign-stub-id foreign-stub-name foreign-stub-return-type
+ lambda-literal-id lambda-literal-external lambda-literal-argument-count
+ lambda-literal-rest-argument lambda-literal-rest-argument-mode
+ lambda-literal-temporaries lambda-literal-unboxed-temporaries
+ lambda-literal-callee-signatures lambda-literal-allocated
+ lambda-literal-closure-size lambda-literal-looping
+ lambda-literal-customizable lambda-literal-body lambda-literal-direct
+
+ ;; Tables and databases that really should not be exported
+ constant-table immutable-constants inline-table line-number-database-2
+ line-number-database-size)
+
+(import chicken scheme foreign srfi-1 extras data-structures
+ scrutinizer support)
(define (d arg1 . more)
(when (##sys#fudge 13) ; debug mode?
@@ -282,27 +332,22 @@
(define-inline (gensym-f-id) (gensym 'f_))
(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
-(define-foreign-variable default-target-heap-size int "C_DEFAULT_TARGET_HEAP_SIZE")
-(define-constant foreign-type-table-size 301)
(define-constant initial-analysis-database-size 3001)
(define-constant default-line-number-database-size 997)
(define-constant inline-table-size 301)
(define-constant constant-table-size 301)
(define-constant file-requirements-size 301)
-(define-constant real-name-table-size 997)
(define-constant default-inline-max-size 20)
;;; Global variables containing compilation parameters:
(define unit-name #f)
-(define number-type 'generic)
(define standard-bindings '())
(define extended-bindings '())
(define insert-timer-checks #t)
(define used-units '())
-(define unsafe #f)
(define foreign-declarations '())
(define emit-trace-info #f)
(define block-compilation #f)
@@ -315,11 +360,9 @@
(define no-argc-checks #f)
(define no-procedure-checks #f)
(define no-global-procedure-checks #f)
-(define source-filename #f)
(define safe-globals-flag #f)
(define explicit-use-flag #f)
(define disable-stack-overflow-checking #f)
-(define require-imports-flag #f)
(define external-protos-first #f)
(define inline-max-size default-inline-max-size)
(define emit-closure-info #t)
@@ -349,31 +392,28 @@
(define inline-table-used #f)
(define constant-table #f)
(define constants-used #f)
-(define broken-constant-nodes '())
(define inline-substitutions-enabled #f)
(define direct-call-ids '())
(define first-analysis #t)
-(define foreign-type-table #f)
(define foreign-variables '())
(define foreign-lambda-stubs '())
-(define foreign-callback-stubs '())
(define external-variables '())
-(define profile-lambda-list '())
-(define profile-lambda-index 0)
-(define profile-info-vector-name #f)
(define external-to-pointer '())
-(define real-name-table #f)
(define location-pointer-map '())
(define pending-canonicalizations '())
(define defconstant-bindings '())
(define callback-names '())
(define toplevel-scope #t)
(define toplevel-lambda-id #f)
-(define csc-control-file #f)
-(define data-declarations '())
(define file-requirements #f)
-(define postponed-initforms '())
+(define unlikely-variables '(unquote unquote-splicing))
+
+;;; Initial bindings. These are supplied (set!) by the (c-)platform
+(define default-extended-bindings '())
+(define default-standard-bindings '())
+(define internal-bindings '())
+(define foldable-bindings '())
;;; Initialize globals:
@@ -387,16 +427,55 @@
(if constant-table
(vector-fill! constant-table '())
(set! constant-table (make-vector constant-table-size '())) )
- (set! profile-info-vector-name (make-random-name 'profile-info))
- (set! real-name-table (make-vector real-name-table-size '()))
+ (reset-profile-info-vector-name!)
+ (clear-real-name-table!)
(if file-requirements
(vector-fill! file-requirements '())
(set! file-requirements (make-vector file-requirements-size '())) )
- (if foreign-type-table
- (vector-fill! foreign-type-table '())
- (set! foreign-type-table (make-vector foreign-type-table-size '())) ) )
+ (clear-foreign-type-table!) )
+;;; Compute general statistics from analysis database:
+;
+; - Returns:
+;
+; current-program-size
+; original-program-size
+; number of known variables
+; number of known procedures
+; number of global variables
+; number of known call-sites
+; number of database entries
+; average bucket load
+
+(define (compute-database-statistics db)
+ (let ((nprocs 0)
+ (nvars 0)
+ (nglobs 0)
+ (entries 0)
+ (nsites 0) )
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (for-each
+ (lambda (prop)
+ (set! entries (+ entries 1))
+ (case (car prop)
+ ((global) (set! nglobs (+ nglobs 1)))
+ ((value)
+ (set! nvars (+ nvars 1))
+ (if (eq? '##core#lambda (node-class (cdr prop)))
+ (set! nprocs (+ nprocs 1)) ) )
+ ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
+ plist) )
+ db)
+ (values current-program-size
+ original-program-size
+ nvars
+ nprocs
+ nglobs
+ nsites
+ entries) ) )
+
;;; Expand macros and canonicalize expressions:
(define (canonicalize-expression exp)
@@ -658,7 +737,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))
@@ -1054,7 +1133,7 @@
(cond [(pair? conv)
(let ([arg (gensym)]
[ret (gensym)] )
- (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
+ (register-foreign-type! name type arg ret)
(mark-variable arg '##compiler#always-bound)
(mark-variable ret '##compiler#always-bound)
(hide-variable arg)
@@ -1067,7 +1146,7 @@
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
e se dest ldest h ln) ) ]
[else
- (##sys#hash-table-set! foreign-type-table name type)
+ (register-foreign-type! name type)
'(##core#undefined) ] ) ) )
((##core#define-external-variable)
@@ -1094,7 +1173,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
@@ -1122,7 +1201,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))
@@ -1144,7 +1223,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)
@@ -1169,7 +1248,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))
@@ -1481,7 +1560,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
@@ -1629,19 +1709,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?)
@@ -1740,12 +1822,9 @@
(list (make-node 'set! (list (first params)) (list r))
(k (varnode t1)) ) ) ) ) ) )
((##core#foreign-callback-wrapper)
- (let ([id (gensym-f-id)]
- [lam (first subs)] )
- (set! foreign-callback-stubs
- (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
- ;; mark to avoid leaf-routine optimization
- (mark-variable id '##compiler#callback-lambda)
+ (let ((id (gensym-f-id))
+ (lam (first subs)) )
+ (register-foreign-callback-stub! id params)
(cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
##core#inline_loc_update)
@@ -1817,18 +1896,6 @@
(walk node values) )
-;;; Foreign callback stub type:
-
-(define-record-type foreign-callback-stub
- (make-foreign-callback-stub id name qualifiers return-type argument-types)
- foreign-callback-stub?
- (id foreign-callback-stub-id) ; symbol
- (name foreign-callback-stub-name) ; string
- (qualifiers foreign-callback-stub-qualifiers) ; string
- (return-type foreign-callback-stub-return-type) ; type-specifier
- (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
-
-
;;; Perform source-code analysis:
(define (analyze-expression node)
@@ -1855,9 +1922,9 @@
(unless (memq var localenv)
(grow 1)
(cond ((memq var env)
- (put! db var 'captured #t))
- ((not (get db var 'global))
- (put! db var 'global #t) ) ) ) ) )
+ (db-put! db var 'captured #t))
+ ((not (db-get db var 'global))
+ (db-put! db var 'global #t) ) ) ) ) )
((##core#callunit ##core#recurse)
(grow 1)
@@ -1879,18 +1946,18 @@
(walk (car vals) env (append params localenv) env2 here #f)
(let ([var (car vars)]
[val (car vals)] )
- (put! db var 'home here)
+ (db-put! db var 'home here)
(assign var val env2 here)
(walk val env localenv fullenv here #f)
(loop (cdr vars) (cdr vals)) ) ) ) ) )
((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
- (lambda (var) (put! db var 'unknown #t))
+ (lambda (var) (db-put! db var 'unknown #t))
vars)
(let ([tl toplevel-scope])
(set! toplevel-scope #f)
@@ -1899,22 +1966,22 @@
((##core#lambda ##core#direct_lambda)
(grow 1)
- (decompose-lambda-list
+ (##sys#decompose-lambda-list
(third params)
(lambda (vars argc rest)
(let ([id (first params)]
[size0 current-program-size] )
(when here
(collect! db here 'contains id)
- (put! db id 'contained-in here) )
+ (db-put! db id 'contained-in here) )
(for-each
(lambda (var)
- (put! db var 'home here)
- (put! db var 'unknown #t) )
+ (db-put! db var 'home here)
+ (db-put! db var 'unknown #t) )
vars)
(when rest
- (put! db rest 'rest-parameter 'list) )
- (when (simple-lambda-node? n) (put! db id 'simple #t))
+ (db-put! db rest 'rest-parameter 'list) )
+ (when (simple-lambda-node? n) (db-put! db id 'simple #t))
(let ([tl toplevel-scope])
(unless toplevel-lambda-id (set! toplevel-lambda-id id))
(when (and (second params) (not (eq? toplevel-lambda-id id)))
@@ -1933,21 +2000,21 @@
(warning "redefinition of standard binding" var) )
((extended)
(warning "redefinition of extended binding" var) ) ))
- (put! db var 'potential-value val)
+ (db-put! db var 'potential-value val)
(unless (memq var localenv)
(grow 1)
(cond ((memq var env)
- (put! db var 'captured #t))
- ((not (get db var 'global))
- (put! db var 'global #t) ) ) )
+ (db-put! db var 'captured #t))
+ ((not (db-get db var 'global))
+ (db-put! db var 'global #t) ) ) )
(assign var val fullenv here)
- (unless toplevel-scope (put! db var 'assigned-locally #t))
- (put! db var 'assigned #t)
+ (unless toplevel-scope (db-put! db var 'assigned-locally #t))
+ (db-put! db var 'assigned #t)
(walk (car subs) env localenv fullenv here #f) ) )
((##core#primitive ##core#inline)
(let ((id (first params)))
- (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id))
+ (when (and first-analysis here (symbol? id) (get-real-name id))
(set-real-name! id here) )
(walkeach subs env localenv fullenv here #f) ) )
@@ -1958,30 +2025,30 @@
(define (assign var val env here)
(cond ((eq? '##core#undefined (node-class val))
- (put! db var 'undefined #t) )
+ (db-put! db var 'undefined #t) )
((and (eq? '##core#variable (node-class val)) ; assignment to itself
(eq? var (first (node-parameters val))) ) )
((or (memq var env)
(variable-mark var '##compiler#constant)
- (not (variable-visible? var)))
- (let ((props (get-all db var 'unknown 'value))
- (home (get db var 'home)) )
+ (not (variable-visible? var block-compilation)))
+ (let ((props (db-get-all db var 'unknown 'value))
+ (home (db-get db var 'home)) )
(unless (assq 'unknown props)
(if (assq 'value props)
- (put! db var 'unknown #t)
+ (db-put! db var 'unknown #t)
(if (or (not home) (eq? here home))
- (put! db var 'value val)
- (put! db var 'unknown #t) ) ) ) ) )
+ (db-put! db var 'value val)
+ (db-put! db var 'unknown #t) ) ) ) ) )
((and (or local-definitions
(variable-mark var '##compiler#local))
- (not (get db var 'unknown)))
- (let ((home (get db var 'home)))
- (cond ((get db var 'local-value)
- (put! db var 'unknown #t))
+ (not (db-get db var 'unknown)))
+ (let ((home (db-get db var 'home)))
+ (cond ((db-get db var 'local-value)
+ (db-put! db var 'unknown #t))
((or (not home) (eq? here home))
- (put! db var 'local-value val) )
- (else (put! db var 'unknown #t)))))
- (else (put! db var 'unknown #t)) ) )
+ (db-put! db var 'local-value val) )
+ (else (db-put! db var 'unknown #t)))))
+ (else (db-put! db var 'unknown #t)) ) )
(define (ref var node)
(collect! db var 'references node) )
@@ -2054,7 +2121,7 @@
global
(null? references)
(not (variable-mark sym '##compiler#unused))
- (not (variable-visible? sym))
+ (not (variable-visible? sym block-compilation))
(not (variable-mark sym '##compiler#constant)) )
(##sys#notice
(sprintf "global variable `~S' is only locally visible and never used"
@@ -2073,8 +2140,9 @@
(when (and (eq? '##core#lambda (node-class value))
(or (not (second valparams))
(every
- (lambda (v) (get db v 'global))
- (nth-value 0 (scan-free-variables value)) ) ) )
+ (lambda (v) (db-get db v 'global))
+ (nth-value 0 (scan-free-variables
+ value block-compilation)) ) ) )
(if (and (= 1 nreferences) (= 1 ncall-sites))
(quick-put! plist 'contractable #t)
(quick-put! plist 'inlinable #t) ) ) ) )
@@ -2082,13 +2150,14 @@
;; Make 'inlinable, if it is declared local and has a value
(let ((valparams (node-parameters local-value)))
(when (eq? '##core#lambda (node-class local-value))
- (let-values (((vars hvars) (scan-free-variables local-value)))
- (when (and (get db sym 'global)
+ (let-values (((vars hvars) (scan-free-variables
+ local-value block-compilation)))
+ (when (and (db-get db sym 'global)
(pair? hvars))
(quick-put! plist 'hidden-refs #t))
(when (or (not (second valparams))
(every
- (lambda (v) (get db v 'global))
+ (lambda (v) (db-get db v 'global))
vars))
(quick-put! plist 'inlinable #t) ) ) ) ) )
((variable-mark sym '##compiler#inline-global) =>
@@ -2122,28 +2191,28 @@
;; - if the procedure is internal (a continuation) do NOT mark unused parameters.
;; - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
(when value
- (let ([has #f])
+ (let ((has #f))
(when (and (eq? '##core#lambda (node-class value))
(= nreferences ncall-sites) )
- (let ([lparams (node-parameters value)])
+ (let ((lparams (node-parameters value)))
(when (second lparams)
- (decompose-lambda-list
+ (##sys#decompose-lambda-list
(third lparams)
(lambda (vars argc rest)
(unless rest
(for-each
(lambda (var)
- (cond [(and (not (get db var 'references))
- (not (get db var 'assigned)) )
- (put! db var 'unused #t)
+ (cond ((and (not (db-get db var 'references))
+ (not (db-get db var 'assigned)) )
+ (db-put! db var 'unused #t)
(set! has #t)
- #t]
- [else #f] ) )
+ #t)
+ (else #f) ) )
vars) )
- (cond [(and has (not (rassoc sym callback-names eq?)))
- (put! db (first lparams) 'has-unused-parameters #t) ]
- [rest
- (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
+ (cond ((and has (not (rassoc sym callback-names eq?)))
+ (db-put! db (first lparams) 'has-unused-parameters #t) )
+ (rest
+ (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
;; Make 'removable, if it has no references and is not assigned to, and if it
;; has either a value that does not cause any side-effects or if it is 'undefined:
@@ -2152,7 +2221,7 @@
(or (and value
(if (eq? '##core#variable (node-class value))
(let ((varname (first (node-parameters value))))
- (or (not (get db varname 'global))
+ (or (not (db-get db varname 'global))
(variable-mark varname '##core#always-bound)
(intrinsic? varname)))
(not (expression-has-side-effects? value db)) ))
@@ -2168,40 +2237,42 @@
;; it was contracted).
(when (and value (not global))
(when (eq? '##core#variable (node-class value))
- (let* ([name (first (node-parameters value))]
- [nrefs (get db name 'references)] )
+ (let* ((name (first (node-parameters value)))
+ (nrefs (db-get db name 'references)) )
(when (and (not captured)
- (or (and (not (get db name 'unknown)) (get db name 'value))
- (and (not (get db name 'captured))
+ (or (and (not (db-get db name 'unknown))
+ (db-get db name 'value))
+ (and (not (db-get db name 'captured))
nrefs
(= 1 (length nrefs))
(not assigned)
- (not (get db name 'assigned))
- (or (not (variable-visible? name))
- (not (get db name 'global))) ) ))
+ (not (db-get db name 'assigned))
+ (or (not (variable-visible?
+ name block-compilation))
+ (not (db-get db name 'global))) ) ))
(quick-put! plist 'replacable name)
- (put! db name 'replacing #t) ) ) ) )
+ (db-put! db name 'replacing #t) ) ) ) )
;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
;; is an internally created procedure: (See above for 'replacing)
(when (and value (eq? '##core#lambda (node-class value)))
- (let ([params (node-parameters value)])
+ (let ((params (node-parameters value)))
(when (not (second params))
- (let ([llist (third params)]
- [body (first (node-subexpressions value))] )
+ (let ((llist (third params))
+ (body (first (node-subexpressions value))) )
(when (and (pair? llist)
(null? (cdr llist))
(eq? '##core#call (node-class body)) )
- (let ([subs (node-subexpressions body)])
+ (let ((subs (node-subexpressions body)))
(when (= 2 (length subs))
- (let ([v1 (first subs)]
- [v2 (second subs)] )
+ (let ((v1 (first subs))
+ (v2 (second subs)) )
(when (and (eq? '##core#variable (node-class v1))
(eq? '##core#variable (node-class v2))
(eq? (first llist) (first (node-parameters v2))) )
- (let ([kvar (first (node-parameters v1))])
+ (let ((kvar (first (node-parameters v1))))
(quick-put! plist 'replacable kvar)
- (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
+ (db-put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
db)
@@ -2223,11 +2294,11 @@
(customizable '())
(lexicals '()))
- (define (test sym item) (get db sym item))
+ (define (test sym item) (db-get db sym item))
(define (register-customizable! var id)
(set! customizable (lset-adjoin eq? customizable var))
- (put! db id 'customizable #t) )
+ (db-put! db id 'customizable #t) )
(define (register-direct-call! id)
(set! direct-calls (add1 direct-calls))
@@ -2296,7 +2367,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)))
@@ -2309,14 +2380,14 @@
(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)))
(fluid-let ((lexicals (append locals lexicals)))
(let ((c (delete-duplicates (gather (first subs) id vars) eq?)))
- (put! db id 'closure-size (length c))
- (put! db id 'captured-variables c)
+ (db-put! db id 'closure-size (length c))
+ (db-put! db id 'captured-variables c)
(lset-difference eq? c locals vars)))))))
(else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
@@ -2361,24 +2432,24 @@
(maptransform subs here closure) ) ) ) )
((##core#lambda ##core#direct_lambda)
- (let ([llist (third params)])
- (decompose-lambda-list
+ (let ((llist (third params)))
+ (##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
- (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
- [boxedaliases (map cons boxedvars (map gensym boxedvars))]
- [cvar (gensym 'c)]
- [id (if here (first params) 'toplevel)]
- [capturedvars (or (test id 'captured-variables) '())]
- [csize (or (test id 'closure-size) 0)]
- [info (and emit-closure-info (second params) (pair? llist))] )
+ (let* ((boxedvars (filter (lambda (v) (test v 'boxed)) vars))
+ (boxedaliases (map cons boxedvars (map gensym boxedvars)))
+ (cvar (gensym 'c))
+ (id (if here (first params) 'toplevel))
+ (capturedvars (or (test id 'captured-variables) '()))
+ (csize (or (test id 'closure-size) 0))
+ (info (and emit-closure-info (second params) (pair? llist))) )
;; If rest-parameter is boxed: mark it as 'boxed-rest
;; (if we don't do this than preparation will think the (boxed) alias
;; of the rest-parameter is never used)
- (and-let* ([rest]
- [(test rest 'boxed)]
- [rp (test rest 'rest-parameter)] )
- (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
+ (and-let* ((rest)
+ ((test rest 'boxed))
+ (rp (test rest 'rest-parameter)) )
+ (db-put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
(make-node
'##core#closure (list (+ csize (if info 2 1)))
(cons
@@ -2491,6 +2562,7 @@
lambda-literal?
(id lambda-literal-id) ; symbol
(external lambda-literal-external) ; boolean
+ ;; lambda-literal-arguments is used nowhere
(arguments lambda-literal-arguments) ; (symbol ...)
(argument-count lambda-literal-argument-count) ; integer
(rest-argument lambda-literal-rest-argument) ; symbol | #f
@@ -2498,6 +2570,7 @@
(unboxed-temporaries lambda-literal-unboxed-temporaries) ; ((sym . utype) ...)
(callee-signatures lambda-literal-callee-signatures) ; (integer ...)
(allocated lambda-literal-allocated) ; integer
+ ;; lambda-literal-directly-called is used nowhere
(directly-called lambda-literal-directly-called) ; boolean
(closure-size lambda-literal-closure-size) ; integer
(looping lambda-literal-looping) ; boolean
@@ -2535,8 +2608,8 @@
unsafe
(variable-mark var '##compiler#always-bound)
(intrinsic? var))]
- [blockvar (and (get db var 'assigned)
- (not (variable-visible? var)))])
+ [blockvar (and (db-get db var 'assigned)
+ (not (variable-visible? var block-compilation)))])
(when blockvar (set! fastrefs (add1 fastrefs)))
(make-node
'##core#global
@@ -2568,11 +2641,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)
@@ -2607,26 +2680,27 @@
(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)]
- [rest-mode
+ (let* ((id (first params))
+ (rest-mode
(and rest
- (let ([rrefs (get db rest 'references)])
- (cond [(get db rest 'assigned) 'list]
- [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none]
- [else (get db rest 'rest-parameter)] ) ) ) ]
- [body (walk
+ (let ((rrefs (db-get db rest 'references)))
+ (cond ((db-get db rest 'assigned) 'list)
+ ((and (not (db-get db rest 'boxed-rest))
+ (or (not rrefs) (null? rrefs))) 'none)
+ (else (db-get db rest 'rest-parameter)) ) ) ) )
+ (body (walk
(car subs)
(##sys#fast-reverse (if (eq? 'none rest-mode)
- (butlast vars)
- vars))
- (if (eq? 'none rest-mode)
+ (butlast vars)
+ vars))
+ (if (eq? 'none rest-mode)
(fx- (length vars) 1)
(length vars))
id
- '()) ] )
+ '()) ) )
(when (eq? rest-mode 'none)
(debugging 'o "unused rest argument" rest id))
(when (and direct rest)
@@ -2645,13 +2719,13 @@
signatures
allocated
(or direct (memq id direct-call-ids))
- (or (get db id 'closure-size) 0)
+ (or (db-get db id 'closure-size) 0)
(and (not rest)
(> looping 0)
(begin
(debugging 'o "identified direct recursive calls" id looping)
#t) )
- (or direct (get db id 'customizable))
+ (or direct (db-get db id 'customizable))
rest-mode
body
direct) )
@@ -2684,18 +2758,19 @@
(walk (second subs) e e-count here boxes) ) ) ) )
((set!)
- (let ([var (first params)]
- [val (first subs)] )
+ (let ((var (first params))
+ (val (first subs)) )
(cond ((posq var e)
=> (lambda (i)
(make-node '##core#setlocal
(list (fx- e-count (fx+ i 1)))
(list (walk val e e-count here boxes)) ) ) )
(else
- (let* ([cval (node-class val)]
- [blockvar (not (variable-visible? var))]
- [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
- (eq? '##core#undefined cval) ) ] )
+ (let* ((cval (node-class val))
+ (blockvar (not (variable-visible?
+ var block-compilation)))
+ (immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
+ (eq? '##core#undefined cval) ) ) )
(when blockvar (set! fastsets (add1 fastsets)))
(make-node
(if immf '##core#setglobal_i '##core#setglobal)
@@ -2707,7 +2782,7 @@
(list (walk (car subs) e e-count here boxes)) ) ) ) ) ) )
((##core#call)
- (let ([len (length (cdr subs))])
+ (let ((len (length (cdr subs))))
(set! signatures (lset-adjoin = signatures len))
(when (and (>= (length params) 3) (eq? here (third params)))
(set! looping (add1 looping)) )
@@ -2729,7 +2804,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)) '())) ) ) )
@@ -2817,3 +2892,4 @@
(debugging 'o "fast global assignments" fastsets))
(values node2 (##sys#fast-reverse literals)
(##sys#fast-reverse lambda-info-literals) lambda-table) ) ) )
+)
\ No newline at end of file
diff --git a/defaults.make b/defaults.make
index 6c1794f7..25b176f3 100644
--- a/defaults.make
+++ b/defaults.make
@@ -256,13 +256,11 @@ endif
CHICKEN_OPTIONS += $(EXTRA_CHICKEN_OPTIONS)
CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use -no-trace
CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -local
-CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS) -no-trace
ifndef DEBUGBUILD
CHICKEN_PROGRAM_OPTIONS += -no-trace
-CHICKEN_COMPILER_OPTIONS += -no-trace
endif
CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
@@ -371,9 +369,6 @@ endif
$(call echo, >>, $@,#ifndef C_INSTALL_MORE_STATIC_LIBS)
$(call echo, >>, $@,# define C_INSTALL_MORE_STATIC_LIBS "$(LIBRARIES)")
$(call echo, >>, $@,#endif)
- $(call echo, >>, $@,#ifndef C_DEFAULT_TARGET_HEAP_SIZE)
- $(call echo, >>, $@,# define C_DEFAULT_TARGET_HEAP_SIZE 0)
- $(call echo, >>, $@,#endif)
$(call echo, >>, $@,#ifndef C_STACK_GROWS_DOWNWARD)
$(call echo, >>, $@,# define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION))
$(call echo, >>, $@,#endif)
diff --git a/distribution/manifest b/distribution/manifest
index 5a360685..11882675 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -6,12 +6,17 @@ config-arch.sh
identify.sh
banner.scm
batch-driver.scm
+batch-driver.import.scm
batch-driver.c
c-backend.c
+c-backend.import.scm
c-platform.c
+c-platform.import.scm
chicken-profile.c
chicken.c
+chicken.import.scm
compiler.c
+compiler.import.scm
csc.c
csi.c
eval.c
@@ -22,8 +27,11 @@ extras.c
library.c
lolevel.c
optimizer.c
+optimizer.import.scm
compiler-syntax.c
+compiler-syntax.import.scm
scrutinizer.c
+scrutinizer.import.scm
irregex.c
posixunix.c
posixwin.c
@@ -37,6 +45,7 @@ srfi-18.c
srfi-4.c
stub.c
support.c
+support.import.scm
tcp.c
utils.c
build.scm
@@ -76,6 +85,7 @@ irregex.scm
irregex-core.scm
irregex-utils.scm
lfa2.c
+lfa2.import.scm
lfa2.scm
posixunix.scm
posixwin.scm
@@ -234,8 +244,6 @@ GNUmakefile
config.make
rules.make
defaults.make
-private-namespace.scm
-compiler-namespace.scm
synrules.scm
expand.scm
expand.c
diff --git a/eval.scm b/eval.scm
index bbcd86c0..3c4777d2 100644
--- a/eval.scm
+++ b/eval.scm
@@ -720,7 +720,8 @@
[(##core#declare)
(if (memq #:compiling ##sys#features)
- (for-each (lambda (d) (##compiler#process-declaration d se)) (cdr x))
+ ;; XXX FIXME: This is a bit of a hack. Why is it needed at all?
+ (for-each (lambda (d) (compiler#process-declaration d se)) (cdr x))
(##sys#notice
"declarations are ignored in interpreted code"
x) )
@@ -1286,7 +1287,8 @@
(define (add-req id syntax?)
(when comp?
(##sys#hash-table-update!
- ##compiler#file-requirements
+ ;; XXX FIXME: This is a bit of a hack. Why is it needed at all?
+ compiler#file-requirements
(if syntax? 'dynamic/syntax 'dynamic)
(cut lset-adjoin eq? <> id) ;XXX assumes compiler has srfi-1 loaded
(lambda () (list id)))))
diff --git a/lfa2.scm b/lfa2.scm
index be49afa3..0d976d36 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -34,18 +34,22 @@
(declare
(unit lfa2)
- (hide d-depth lfa2-debug d dd +type-check-map+ +predicate-map+))
+ (uses srfi-1
+ support) )
+(module lfa2
+ (perform-secondary-flow-analysis)
-(include "compiler-namespace")
-(include "tweaks")
+(import chicken scheme srfi-1
+ support)
+(include "tweaks")
(define d-depth 0)
(define lfa2-debug #t)
(define (d fstr . args)
- (when (and scrutiny-debug (##sys#fudge 13))
+ (when (and lfa2-debug (##sys#fudge 13))
(printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) )
(define dd d)
@@ -183,14 +187,14 @@
(else (set! stats (alist-cons elim 1 stats)))))
(define (assigned? var)
- (get db var 'assigned))
+ (db-get db var 'assigned))
(define (droppable? n)
(or (memq (node-class n)
'(quote ##core#undefined ##core#primitive ##core#lambda))
(and (eq? '##core#variable (node-class n))
(let ((var (first (node-parameters n))))
- (or (not (get db var 'global))
+ (or (not (db-get db var 'global))
(variable-mark var '##compiler#always-bound))))))
(define (drop! n)
@@ -359,3 +363,4 @@
(for-each
(lambda (ss) (printf " ~a:\t~a~%" (car ss) (cdr ss)))
stats))))))
+)
diff --git a/optimizer.scm b/optimizer.scm
index fb411914..3425af95 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -27,14 +27,27 @@
(declare
(unit optimizer)
- (not inline ##sys#compiler-syntax-hook) )
+ (uses srfi-1 data-structures
+ support) )
+(module optimizer
+ (scan-toplevel-assignments perform-high-level-optimizations
+ transform-direct-lambdas! determine-loop-and-dispatch
+ eq-inline-operator membership-test-operators membership-unfold-limit
+ default-optimization-passes rewrite)
+
+(import chicken scheme srfi-1 data-structures
+ support)
-(include "compiler-namespace")
(include "tweaks")
(define-constant maximal-number-of-free-variables-for-liftable 16)
+;; These are parameterized by the platform implementation
+(define eq-inline-operator (make-parameter #f))
+(define membership-test-operators (make-parameter #f))
+(define membership-unfold-limit (make-parameter #f))
+(define default-optimization-passes (make-parameter #f))
;;; Scan toplevel expressions for assignments:
@@ -130,16 +143,18 @@
(define simplifications (make-vector 301 '()))
(define simplified-ops '())
-
-(define (perform-high-level-optimizations node db)
- (let ([removed-lets 0]
- [removed-ifs 0]
- [replaced-vars 0]
- [rest-consers '()]
- [simplified-classes '()]
- [dirty #f] )
-
- (define (test sym item) (get db sym item))
+(define broken-constant-nodes '())
+
+(define (perform-high-level-optimizations
+ node db block-compilation may-inline inline-limit may-rewrite)
+ (let ((removed-lets 0)
+ (removed-ifs 0)
+ (replaced-vars 0)
+ (rest-consers '())
+ (simplified-classes '())
+ (dirty #f) )
+
+ (define (test sym item) (db-get db sym item))
(define (constant-node? n) (eq? 'quote (node-class n)))
(define (node-value n) (first (node-parameters n)))
(define (touch) (set! dirty #t))
@@ -148,14 +163,15 @@
(for-each (cut set-cdr! <> #f) gae))
(define (simplify n)
- (or (and-let* ([entry (##sys#hash-table-ref simplifications (node-class n))])
+ (or (and-let* ((entry (##sys#hash-table-ref
+ simplifications (node-class n))))
(any (lambda (s)
- (and-let* ([vars (second s)]
- [env (match-node n (first s) vars)]
- [n2 (apply (third s) db
- (map (lambda (v) (cdr (assq v env))) vars) ) ] )
- (let* ([name (caar s)]
- [counter (assq name simplified-classes)] )
+ (and-let* ((vars (second s))
+ (env (match-node n (first s) vars))
+ (n2 (apply (third s) db may-rewrite
+ (map (lambda (v) (cdr (assq v env))) vars) ) ) )
+ (let* ((name (caar s))
+ (counter (assq name simplified-classes)) )
(if counter
(set-cdr! counter (add1 (cdr counter)))
(set! simplified-classes (alist-cons name 1 simplified-classes)) )
@@ -216,7 +232,7 @@
(lambda (rvar)
(let ((final-var (replace-var rvar)))
;; Store intermediate vars to avoid recurring same chain again
- (put! db var 'replacable final-var)
+ (db-put! db var 'replacable final-var)
final-var)))
(else var)))
@@ -267,7 +283,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)
@@ -284,7 +300,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)
@@ -323,7 +339,7 @@
(check-signature var args llist)
(debugging 'o "contracted procedure" info)
(touch)
- (for-each (cut put! db <> 'inline-target #t) fids)
+ (for-each (cut db-put! db <> 'inline-target #t) fids)
(walk
(inline-lambda-bindings
llist args (first (node-subexpressions lval)) #f db
@@ -356,26 +372,26 @@
;; 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))
(external (node? (variable-mark var '##compiler#inline-global))))
- (cond ((and inline-locally
+ (cond ((and may-inline
(test var 'inlinable)
(not (test ifid 'inline-target)) ; inlinable procedure has changed
(not (test ifid 'explicit-rest))
(case (variable-mark var '##compiler#inline)
((no) #f)
(else
- (or external (< (fourth lparams) inline-max-size)))))
+ (or external (< (fourth lparams) inline-limit)))))
(debugging
'i
(if external
"global inlining"
"inlining")
info ifid (fourth lparams))
- (for-each (cut put! db <> 'inline-target #t) fids)
+ (for-each (cut db-put! db <> 'inline-target #t) fids)
(check-signature var args llist)
(debugging 'o "inlining procedure" info)
(call/cc
@@ -480,7 +496,7 @@
(touch)
(make-node '##core#undefined '() '()) )
((and (or (not (test var 'global))
- (not (variable-visible? var)))
+ (not (variable-visible? var block-compilation)))
(not (test var 'inline-transient))
(not (test var 'references))
(not (expression-has-side-effects? (first subs) db)) )
@@ -551,7 +567,7 @@
(removed-nots 0) )
(define (touch) (set! dirty #t) #t)
- (define (test sym prop) (get db sym prop))
+ (define (test sym prop) (db-get db sym prop))
(debugging 'p "pre-optimization phase...")
@@ -563,7 +579,7 @@
(subs (node-subexpressions n))
(kont (first (node-parameters (second subs))))
(lnode (and (not (test kont 'unknown)) (test kont 'value)))
- (krefs (get-list db kont 'references)) )
+ (krefs (db-get-list db kont 'references)) )
;; Call-site has one argument and a known continuation (which is a ##core#lambda)
;; that has only one use:
(when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
@@ -574,7 +590,7 @@
;; Continuation has one parameter?
(if (and (proper-list? llist) (null? (cdr llist)))
(let* ((var (car llist))
- (refs (get-list db var 'references)) )
+ (refs (db-get-list db var 'references)) )
;; Parameter is only used once?
(if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
;; Continuation contains an 'if' node?
@@ -609,10 +625,11 @@
;; (<named-call> ...) -> (<primitive-call/inline> ...)
`((##core#call d (##core#variable (a)) b . c)
(a b c d)
- ,(lambda (db a b c d)
+ ,(lambda (db may-rewrite a b c d)
(let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
(cond ((null? entries) #f)
- ((simplify-named-call db d a b (caar entries) (cdar entries) c)
+ ((simplify-named-call db may-rewrite d a b
+ (caar entries) (cdar entries) c)
=> (lambda (r)
(let ((as (assq a simplified-ops)))
(if as
@@ -640,12 +657,12 @@
body2
rest) ) ) )
(var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
- ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
- (and (equal? op eq-inline-operator)
+ ,(lambda (db may-rewrite var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
+ (and (equal? op (eq-inline-operator))
(immediate? const1)
(immediate? const2)
- (= 1 (length (get-list db var1 'references)))
- (= 1 (length (get-list db var2 'references)))
+ (= 1 (length (db-get-list db var1 'references)))
+ (= 1 (length (db-get-list db var2 'references)))
(make-node
'##core#switch
'(2)
@@ -667,10 +684,10 @@
body
(##core#switch (n) (##core#variable (var0)) . clauses) ) )
(var op var0 const d body n clauses)
- ,(lambda (db var op var0 const d body n clauses)
- (and (equal? op eq-inline-operator)
+ ,(lambda (db may-rewrite var op var0 const d body n clauses)
+ (and (equal? op (eq-inline-operator))
(immediate? const)
- (= 1 (length (get-list db var 'references)))
+ (= 1 (length (db-get-list db var 'references)))
(make-node
'##core#switch
(list (add1 n))
@@ -691,47 +708,47 @@
`((let (var1) (##core#undefined ())
more)
(var1 more)
- ,(lambda (db var1 more)
- (let loop1 ([vars (list var1)]
- [body more] )
- (let ([c (node-class body)]
- [params (node-parameters body)]
- [subs (node-subexpressions body)] )
+ ,(lambda (db may-rewrite var1 more)
+ (let loop1 ((vars (list var1))
+ (body more) )
+ (let ((c (node-class body))
+ (params (node-parameters body))
+ (subs (node-subexpressions body)) )
(and (eq? c 'let)
(null? (cdr params))
- (not (get db (first params) 'inline-transient))
- (not (get db (first params) 'references))
- (let* ([val (first subs)]
- [valparams (node-parameters val)]
- [valsubs (node-subexpressions val)] )
+ (not (db-get db (first params) 'inline-transient))
+ (not (db-get db (first params) 'references))
+ (let* ((val (first subs))
+ (valparams (node-parameters val))
+ (valsubs (node-subexpressions val)) )
(case (node-class val)
- [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
- [(set!)
- (let ([allvars (reverse vars)])
+ ((##core#undefined) (loop1 (cons (first params) vars) (second subs)))
+ ((set!)
+ (let ((allvars (reverse vars)))
(and (pair? allvars)
(eq? (first valparams) (first allvars))
- (let loop2 ([vals (list (first valsubs))]
- [vars (cdr allvars)]
- [body (second subs)] )
- (let ([c (node-class body)]
- [params (node-parameters body)]
- [subs (node-subexpressions body)] )
- (cond [(and (eq? c 'let)
+ (let loop2 ((vals (list (first valsubs)))
+ (vars (cdr allvars))
+ (body (second subs)) )
+ (let ((c (node-class body))
+ (params (node-parameters body))
+ (subs (node-subexpressions body)) )
+ (cond ((and (eq? c 'let)
(null? (cdr params))
- (not (get db (first params) 'inline-transient))
- (not (get db (first params) 'references))
+ (not (db-get db (first params) 'inline-transient))
+ (not (db-get db (first params) 'references))
(pair? vars)
(eq? 'set! (node-class (first subs)))
(eq? (car vars) (first (node-parameters (first subs)))) )
(loop2 (cons (first (node-subexpressions (first subs))) vals)
(cdr vars)
- (second subs) ) ]
- [(null? vars)
+ (second subs) ) )
+ ((null? vars)
(receive (n progress)
(reorganize-recursive-bindings allvars (reverse vals) body)
- (and progress n) ) ]
- [else #f] ) ) ) ) ) ]
- [else #f] ) ) ) ) ) ) )
+ (and progress n) ) )
+ (else #f) ) ) ) ) ) )
+ (else #f) ) ) ) ) ) ) )
;; (let ((<var1> <var2>))
;; (<var1> ...) )
@@ -741,8 +758,8 @@
`((let (var1) (##core#variable (var2))
(##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
(var1 var2 p more)
- ,(lambda (db var1 var2 p more)
- (and (= 1 (length (get-list db var1 'references)))
+ ,(lambda (db may-rewrite var1 var2 p more)
+ (and (= 1 (length (db-get-list db var1 'references)))
(make-node
'##core#call p
(cons (varnode var2) more) ) ) ) )
@@ -758,9 +775,9 @@
x
y) )
(var op args d x y)
- ,(lambda (db var op args d x y)
- (and (not (equal? op eq-inline-operator))
- (= 1 (length (get-list db var 'references)))
+ ,(lambda (db may-rewrite var op args d x y)
+ (and (not (equal? op (eq-inline-operator)))
+ (= 1 (length (db-get-list db var 'references)))
(make-node
'if d
(list (make-node '##core#inline (list op) args)
@@ -779,8 +796,8 @@
(##core#call d2 (##core#variable (var)) y)
(##core#call d3 (##core#variable (var)) z) )
(d1 d2 d3 x y z var)
- ,(lambda (db d1 d2 d3 x y z var)
- (and inline-substitutions-enabled
+ ,(lambda (db may-rewrite d1 d2 d3 x y z var)
+ (and may-rewrite
(make-node
'##core#call d2
(list (varnode var)
@@ -794,10 +811,10 @@
y
z)
(d1 op x clist y z)
- ,(lambda (db d1 op x clist y z)
- (and-let* ([opa (assoc op membership-test-operators)]
+ ,(lambda (db may-rewrite d1 op x clist y z)
+ (and-let* ([opa (assoc op (membership-test-operators))]
[(proper-list? clist)]
- [(< (length clist) membership-unfold-limit)] )
+ [(< (length clist) (membership-unfold-limit))] )
(let ([var (gensym)]
[eop (list (cdr opa))] )
(make-node
@@ -916,8 +933,9 @@
(let ((old (or (##sys#hash-table-ref substitution-table name) '())))
(##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
-(define (simplify-named-call db params name cont class classargs callargs)
- (define (test sym prop) (get db sym prop))
+(define (simplify-named-call db may-rewrite params name cont
+ class classargs callargs)
+ (define (test sym prop) (db-get db sym prop))
(define (defarg x)
(cond ((symbol? x) (varnode x))
((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
@@ -936,7 +954,7 @@
(eq? '##core#variable (node-class arg2))
(equal? (node-parameters arg1) (node-parameters arg2))
(make-node '##core#call (list #t) (list cont (qnode #t))) ) ) )
- (and inline-substitutions-enabled
+ (and may-rewrite
(make-node
'##core#call (list #t)
(list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
@@ -944,7 +962,7 @@
;; (<op> ...) -> (##core#inline <iop> ...)
((2) ; classargs = (<argc> <iop> <safe>)
;; - <safe> by be 'specialized (see rule #16 below)
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(or (third classargs) unsafe)
@@ -958,7 +976,7 @@
;; (<op> ...) -> <var>
((3) ; classargs = (<var> <argc>)
;; - <argc> may be #f
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (not (second classargs)) (= (length callargs) (second classargs)))
(fold-right
@@ -969,7 +987,7 @@
;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
((4) ; classargs = (<primitiveop> <i>)
- (and inline-substitutions-enabled
+ (and may-rewrite
unsafe
(= 2 (length callargs))
(intrinsic? name)
@@ -983,7 +1001,7 @@
;; (<op> a) -> (##core#inline <iop> a (quote <x>))
((5) ; classargs = (<iop> <x> <numtype>)
;; - <numtype> may be #f
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(= 1 (length callargs))
(let ((ntype (third classargs)))
@@ -997,7 +1015,7 @@
;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
((6) ; classargs = (<iop1> <iop2> <safe>)
(and (or (third classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= 1 (length callargs))
(intrinsic? name)
(make-node '##core#call (list #t)
@@ -1009,7 +1027,7 @@
;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
((7) ; classargs = (<argc> <iop> <x> <safe>)
(and (or (fourth classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(make-node '##core#call (list #t)
@@ -1020,32 +1038,32 @@
;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
((8) ; classargs = (<proc> ...)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
((first classargs) db classargs cont callargs) ) )
;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
;; (<op> [<x>]) -> (quote #t)
((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(if (< (length callargs) 2)
(make-node '##core#call (list #t) (list cont (qnode #t)))
(and (or (and unsafe (not (eq? number-type 'generic)))
(and (eq? number-type 'fixnum) (third classargs))
(and (eq? number-type 'flonum) (fourth classargs)) )
- (let* ([names (map (lambda (z) (gensym)) callargs)]
- [vars (map varnode names)] )
+ (let* ((names (map (lambda (z) (gensym)) callargs))
+ (vars (map varnode names)) )
(fold-right
(lambda (x n y) (make-node 'let (list n) (list x y)))
(make-node
'##core#call (list #t)
(list
cont
- (let ([op (list
+ (let ((op (list
(if (eq? number-type 'fixnum)
(first classargs)
- (second classargs) ) ) ] )
+ (second classargs) ) ) ) )
(fold-boolean
(lambda (x y) (make-node '##core#inline op (list x y)))
vars) ) ) )
@@ -1053,7 +1071,7 @@
;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (fourth classargs) unsafe)
(intrinsic? name)
(let ((n (length callargs)))
@@ -1070,10 +1088,10 @@
;; (<op> ...) -> (<primitiveop> ...)
((11) ; classargs = (<argc> <primitiveop> <safe>)
;; <argc> may be #f.
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (third classargs) unsafe)
(intrinsic? name)
- (let ([argc (first classargs)])
+ (let ((argc (first classargs)))
(and (or (not argc)
(= (length callargs) (first classargs)) )
(make-node '##core#call (list #t (second classargs))
@@ -1084,7 +1102,7 @@
;; (<op> a) -> a
;; (<op> ...) -> (<primitiveop> ...)
((12) ; classargs = (<primitiveop> <safe> <maxargc>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (second classargs) unsafe)
(let ((n (length callargs)))
@@ -1097,7 +1115,7 @@
;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
((13) ; classargs = (<primitiveop> <safe>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (second classargs) unsafe)
(let ((pname (first classargs)))
@@ -1107,7 +1125,7 @@
;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (second classargs) (length callargs))
(intrinsic? name)
(eq? number-type (first classargs))
@@ -1123,7 +1141,7 @@
;; (<op> <x>) -> (<primitiveop> <x>) - if numtype1
;; | <x> - if numtype2
((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(= 1 (length callargs))
(or unsafe (fourth classargs))
(intrinsic? name)
@@ -1148,7 +1166,7 @@
(safe (third classargs))
(w (fourth classargs))
(counted (and (pair? (cddddr classargs)) (fifth classargs))))
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (not argc) (= rargc argc))
(intrinsic? name)
(or unsafe safe)
@@ -1160,14 +1178,14 @@
(list (if (and counted (positive? rargc) (<= rargc 8))
(conc (second classargs) rargc)
(second classargs) )
- (cond [(eq? #t w) (add1 rargc)]
- [(pair? w) (* rargc (car w))]
- [else w] ) )
+ (cond ((eq? #t w) (add1 rargc))
+ ((pair? w) (* rargc (car w)))
+ (else w) ) )
callargs) ) ) ) ) )
;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(make-node
@@ -1181,7 +1199,7 @@
;; (<op>) -> (quote <null>)
((18) ; classargs = (<null>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(null? callargs)
(intrinsic? name)
(make-node '##core#call (list #t) (list cont (qnode (first classargs))) ) ) )
@@ -1192,20 +1210,20 @@
;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
;; - Remove "<id>" from arguments.
((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
- (let* ([id (first classargs)]
- [fixop (if unsafe (third classargs) (second classargs))]
- [callargs
+ (let* ((id (first classargs))
+ (fixop (if unsafe (third classargs) (second classargs)))
+ (callargs
(remove
(lambda (x)
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
- callargs) ] )
- (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
- [(null? (cdr callargs))
- (make-node '##core#call (list #t) (list cont (first callargs))) ]
- [(or (fourth classargs) (eq? number-type 'fixnum))
+ callargs) ) )
+ (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
+ ((null? (cdr callargs))
+ (make-node '##core#call (list #t) (list cont (first callargs))) )
+ ((or (fourth classargs) (eq? number-type 'fixnum))
(make-node
'##core#call (list #t)
(list
@@ -1213,14 +1231,14 @@
(fold-inner
(lambda (x y)
(make-node '##core#inline (list fixop) (list x y)) )
- callargs) ) ) ]
- [else #f] ) ) ) )
+ callargs) ) ) )
+ (else #f) ) ) ) )
;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
((20) ; classargs = (<argc> <iop> <x> <safe>)
- (let ([n (length callargs)])
+ (let ((n (length callargs)))
(and (or (fourth classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= n (first classargs))
(intrinsic? name)
(make-node
@@ -1228,7 +1246,7 @@
(list cont
(make-node
'##core#inline (list (second classargs))
- (let-values ([(head tail) (split-at callargs (sub1 n))])
+ (let-values (((head tail) (split-at callargs (sub1 n))))
(append head
(list (qnode (third classargs)))
tail) ) ) ) ) ) ) )
@@ -1239,22 +1257,22 @@
;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
;; - Remove "<id>" from arguments.
((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
- (let* ([id (first classargs)]
- [words (fifth classargs)]
- [genop (fourth classargs)]
- [fixop (if unsafe (third classargs) (second classargs))]
- [callargs
+ (let* ((id (first classargs))
+ (words (fifth classargs))
+ (genop (fourth classargs))
+ (fixop (if unsafe (third classargs) (second classargs)))
+ (callargs
(remove
(lambda (x)
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
- callargs) ] )
- (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
- [(null? (cdr callargs))
- (make-node '##core#call (list #t) (list cont (first callargs))) ]
- [else
+ callargs) ) )
+ (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
+ ((null? (cdr callargs))
+ (make-node '##core#call (list #t) (list cont (first callargs))) )
+ (else
(make-node
'##core#call (list #t)
(list
@@ -1264,15 +1282,15 @@
(if (eq? number-type 'fixnum)
(make-node '##core#inline (list fixop) (list x y))
(make-node '##core#inline_allocate (list genop words) (list x y)) ) )
- callargs) ) ) ] ) ) ) )
+ callargs) ) ) ) ) ) ) )
;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
- (let ([argc (first classargs)]
- [rargc (length callargs)]
- [w (fourth classargs)] )
- (and inline-substitutions-enabled
+ (let ((argc (first classargs))
+ (rargc (length callargs))
+ (w (fourth classargs)) )
+ (and may-rewrite
(= rargc argc)
(intrinsic? name)
(or (third classargs) unsafe)
@@ -1294,7 +1312,7 @@
;; - default args in classargs should be either symbol or (optionally)
;; quoted literal
((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(let ([argc (first classargs)])
(and (>= (length callargs) (first classargs))
@@ -1321,10 +1339,10 @@
;;; Optimize direct leaf routines:
(define (transform-direct-lambdas! node db)
- (let ([dirty #f]
- [inner-ks '()]
- [hoistable '()]
- [allocated 0] )
+ (let ((dirty #f)
+ (inner-ks '())
+ (hoistable '())
+ (allocated 0) )
;; Process node tree and walk lambdas that meet the following constraints:
;; - Only external lambdas (no CPS redexes),
@@ -1334,18 +1352,18 @@
;; - The lambda is not marked as a callback lambda
(define (walk d n dn)
- (let ([params (node-parameters n)]
- [subs (node-subexpressions n)] )
+ (let ((params (node-parameters n))
+ (subs (node-subexpressions n)) )
(case (node-class n)
- [(##core#lambda)
- (let ([llist (third params)])
+ ((##core#lambda)
+ (let ((llist (third params)))
(if (and d
(second params)
- (not (get db d 'unknown))
+ (not (db-get db d 'unknown))
(proper-list? llist)
- (and-let* ([val (get db d 'value)]
- [refs (get-list db d 'references)]
- [sites (get-list db d 'call-sites)] )
+ (and-let* ((val (db-get db d 'value))
+ (refs (db-get-list db d 'references))
+ (sites (db-get-list db d 'call-sites)) )
;; val must be lambda, since `sites' is set
(and (eq? n val)
(not (variable-mark
@@ -1354,87 +1372,87 @@
(= (length refs) (length sites))
(scan (first subs) (first llist) d dn (cons d llist)) ) ) )
(transform n d inner-ks hoistable dn allocated)
- (walk #f (first subs) #f) ) ) ]
- [(set!) (walk (first params) (first subs) #f)]
- [(let)
+ (walk #f (first subs) #f) ) ) )
+ ((set!) (walk (first params) (first subs) #f))
+ ((let)
(walk (first params) (first subs) n)
- (walk #f (second subs) #f) ]
- [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )
+ (walk #f (second subs) #f) )
+ (else (for-each (lambda (x) (walk #f x #f)) subs)) ) ) )
(define (scan n kvar fnvar destn env)
- (let ([closures '()]
- [recursive #f] )
+ (let ((closures '())
+ (recursive #f) )
(define (rec n v vn e)
- (let ([params (node-parameters n)]
- [subs (node-subexpressions n)] )
+ (let ((params (node-parameters n))
+ (subs (node-subexpressions n)) )
(case (node-class n)
- [(##core#variable)
- (let ([v (first params)])
- (or (not (get db v 'boxed))
+ ((##core#variable)
+ (let ((v (first params)))
+ (or (not (db-get db v 'boxed))
(not (memq v env))
(and (not recursive)
(begin
(set! allocated (+ allocated 2))
- #t) ) ) ) ]
- [(##core#lambda)
+ #t) ) ) ) )
+ ((##core#lambda)
(and v
- (decompose-lambda-list
+ (##sys#decompose-lambda-list
(third params)
(lambda (vars argc rest)
(set! closures (cons v closures))
- (rec (first subs) #f #f (append vars e)) ) ) ) ]
- [(##core#inline_allocate)
+ (rec (first subs) #f #f (append vars e)) ) ) ) )
+ ((##core#inline_allocate)
(and (not recursive)
(begin
(set! allocated (+ allocated (second params)))
- (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
- [(##core#direct_lambda)
+ (every (lambda (x) (rec x #f #f e)) subs) ) ) )
+ ((##core#direct_lambda)
(and vn destn
(null? (scan-used-variables (first subs) e))
(begin
(set! hoistable (alist-cons v vn hoistable))
- #t) ) ]
- [(##core#inline_ref)
- (and (let ([n (estimate-foreign-result-size (second params))])
+ #t) ) )
+ ((##core#inline_ref)
+ (and (let ((n (estimate-foreign-result-size (second params))))
(or (zero? n)
(and (not recursive)
(begin
(set! allocated (+ allocated n))
#t) ) ) )
- (every (lambda (x) (rec x #f #f e)) subs) ) ]
- [(##core#inline_loc_ref)
- (and (let ([n (estimate-foreign-result-size (first params))])
+ (every (lambda (x) (rec x #f #f e)) subs) ) )
+ ((##core#inline_loc_ref)
+ (and (let ((n (estimate-foreign-result-size (first params))))
(or (zero? n)
(and (not recursive)
(begin
(set! allocated (+ allocated n))
#t) ) ) )
- (every (lambda (x) (rec x #f #f e)) subs) ) ]
- [(##core#call)
- (let ([fn (first subs)])
+ (every (lambda (x) (rec x #f #f e)) subs) ) )
+ ((##core#call)
+ (let ((fn (first subs)))
(and (eq? '##core#variable (node-class fn))
- (let ([v (first (node-parameters fn))])
- (cond [(eq? v fnvar)
+ (let ((v (first (node-parameters fn))))
+ (cond ((eq? v fnvar)
(and (zero? allocated)
- (let ([k (second subs)])
+ (let ((k (second subs)))
(when (eq? '##core#variable (node-class k))
(set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
(set! recursive #t)
- #t) ) ]
- [else (eq? v kvar)] ) )
- (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
- [(##core#direct_call)
- (let ([n (fourth params)])
+ #t) ) )
+ (else (eq? v kvar)) ) )
+ (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) )
+ ((##core#direct_call)
+ (let ((n (fourth params)))
(or (zero? n)
(and (not recursive)
(begin
(set! allocated (+ allocated n))
- (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
- [(set!) (rec (first subs) (first params) #f e)]
- [(let)
+ (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) )
+ ((set!) (rec (first subs) (first params) #f e))
+ ((let)
(and (rec (first subs) (first params) n e)
- (rec (second subs) #f #f (append params e)) ) ]
- [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
+ (rec (second subs) #f #f (append params e)) ) )
+ (else (every (lambda (x) (rec x #f #f e)) subs)) ) ) )
(set! inner-ks '())
(set! hoistable '())
(set! allocated 0)
@@ -1446,11 +1464,11 @@
(debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
(debugging 'o "direct leaf routine/allocation" fnvar allocated) )
(set! dirty #t)
- (let* ([params (node-parameters n)]
- [argc (length (third params))]
- [klambdas '()]
- [sites (or (get db fnvar 'call-sites) '())]
- [ksites '()] )
+ (let* ((params (node-parameters n))
+ (argc (length (third params)))
+ (klambdas '())
+ (sites (or (db-get db fnvar 'call-sites) '()))
+ (ksites '()) )
(if (and (list? params) (= (length params) 4) (list? (caddr params)))
(let ((id (car params))
(kvar (caaddr params))
@@ -1475,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)
@@ -1486,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)
@@ -1518,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!
@@ -1626,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
@@ -1660,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)))
@@ -1760,4 +1778,4 @@
groups)
(values node (pair? groups))))
-
+)
\ No newline at end of file
diff --git a/private-namespace.scm b/private-namespace.scm
deleted file mode 100644
index a71b552b..00000000
--- a/private-namespace.scm
+++ /dev/null
@@ -1,48 +0,0 @@
-;;;; compiler-namespace.scm - A simple namespace system to keep compiler variables hidden
-;
-; Copyright (c) 2008-2014, The CHICKEN Team
-; Copyright (c) 2007, Felix L. Winkelmann
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(define-syntax private
- (er-macro-transformer
- (lambda (form r c)
- (let ((namespace (cadr form))
- (vars (cddr form)))
- (##sys#check-symbol namespace 'private)
- (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
- (prefix (string-append
- (string (integer->char (string-length str)))
- (symbol->string namespace))))
- (for-each
- (lambda (var)
- (put!
- var 'c:namespace
- (##sys#string->qualified-symbol prefix (symbol->string var))))
- vars)
- '(##core#undefined) ) ) ) ) )
-
-(set! ##sys#alias-global-hook
- (lambda (var . assign) ; must work with old chicken
- (or (get var 'c:namespace) var) ) )
diff --git a/rules.make b/rules.make
index 4269980f..19e620fc 100644
--- a/rules.make
+++ b/rules.make
@@ -492,6 +492,24 @@ endef
$(foreach lib, $(SETUP_API_OBJECTS_1),\
$(eval $(call declare-emitted-import-lib-dependency,$(lib))))
+$(foreach lib, $(filter-out chicken,$(COMPILER_OBJECTS_1)),\
+ $(eval $(call declare-emitted-import-lib-dependency,$(lib))))
+
+chicken.c: chicken.scm batch-driver.import.scm c-platform.import.scm
+batch-driver.c: batch-driver.scm compiler.import.scm \
+ compiler-syntax.import.scm optimizer.import.scm \
+ scrutinizer.import.scm c-platform.import.scm \
+ lfa2.import.scm c-backend.import.scm support.import.scm
+c-platform.c: c-platform.scm optimizer.import.scm support.import.scm \
+ compiler.import.scm
+c-backend.c: c-backend.scm c-platform.import.scm support.import.scm \
+ compiler.import.scm
+compiler.c: compiler.scm scrutinizer.import.scm support.import.scm
+optimizer.c: optimizer.scm support.import.scm
+scrutinizer.c: scrutinizer.scm support.import.scm
+lfa2.c: lfa2.scm support.import.scm
+compiler-syntax.c: compiler-syntax.scm support.import.scm compiler.import.scm
+
define profile-flags
$(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile)
endef
@@ -566,9 +584,8 @@ $(foreach obj, $(IMPORT_LIBRARIES),\
# Bootstrap compiler objects
define declare-bootstrap-compiler-object
-$(1).c: $$(SRCDIR)$(1).scm $$(SRCDIR)compiler-namespace.scm \
- $$(SRCDIR)private-namespace.scm $$(SRCDIR)tweaks.scm
- $$(CHICKEN) $$< $$(CHICKEN_COMPILER_OPTIONS) -output-file $$@
+$(1).c: $$(SRCDIR)$(1).scm $$(SRCDIR)tweaks.scm
+ $$(CHICKEN) $$< $$(CHICKEN_PROGRAM_OPTIONS) -emit-import-library $(1) -output-file $$@
endef
$(foreach obj, $(COMPILER_OBJECTS_1),\
diff --git a/scripts/compile-all b/scripts/compile-all
index 0754b060..c8aa16e7 100755
--- a/scripts/compile-all
+++ b/scripts/compile-all
@@ -5,7 +5,7 @@
set -e
set -x
-compiler_options="-optimize-level 2 -include-path . -include-path ./ -inline -ignore-repository -feature chicken-bootstrap -feature debugbuild -scrutinize -types ./types.db -verbose -no-lambda-info -local -extend private-namespace.scm -specialize"
+compiler_options="-optimize-level 2 -include-path . -include-path ./ -inline -ignore-repository -feature chicken-bootstrap -feature debugbuild -scrutinize -types ./types.db -verbose -no-lambda-info -local -specialize"
library_options="-optimize-level 2 -include-path . -include-path ./ -inline -ignore-repository -feature chicken-bootstrap -feature debugbuild -scrutinize -types ./types.db -verbose -explicit-use -no-trace -specialize"
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c4379331..63f0296f 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -26,18 +26,17 @@
(declare
(unit scrutinizer)
- (hide specialize-node! specialization-statistics
- procedure-type? named? procedure-result-types procedure-argument-types
- noreturn-type? rest-type procedure-name d-depth
- noreturn-procedure-type? trail trail-restore walked-result
- typename multiples procedure-arguments procedure-results
- smash-component-types! generate-type-checks! over-all-instantiations
- compatible-types? type<=? match-types resolve match-argument-types))
+ (uses srfi-1 data-structures extras ports files
+ support) )
+(module scrutinizer
+ (scrutinize load-type-database emit-type-file
+ validate-type check-and-validate-type install-specializations)
-(include "compiler-namespace")
-(include "tweaks")
+(import chicken scheme srfi-1 data-structures extras ports files
+ support)
+(include "tweaks")
(define d-depth 0)
(define scrutiny-debug #t)
@@ -123,7 +122,7 @@
(first (node-parameters n))) ; assumes ##core#the/result node
-(define (scrutinize node db complain specialize)
+(define (scrutinize node db complain specialize strict block-compilation)
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
(noreturn #f)
@@ -187,8 +186,8 @@
(define (variable-result id e loc flow)
(cond ((blist-type id flow) => list)
- ((and (not strict-variable-types)
- (get db id 'assigned)
+ ((and (not strict)
+ (db-get db id 'assigned)
(not (variable-mark id '##compiler#declared-type)))
'(*))
((assq id e) =>
@@ -442,8 +441,7 @@
(loop (cdr a))))))
(define (initial-argument-types dest vars argc)
- (if (and dest
- strict-variable-types
+ (if (and dest strict
(variable-mark dest '##compiler#declared-type))
(let* ((ptype (variable-mark dest '##compiler#type))
(typeenv (type-typeenv ptype)))
@@ -546,13 +544,13 @@
(walk val e loc var #f flow #f)
loc)))
(when (and (eq? (node-class val) '##core#variable)
- (not (get db var 'assigned)))
+ (not (db-get db var 'assigned)))
(let ((var2 (first (node-parameters val))))
- (unless (get db var2 'assigned) ;XXX too conservative?
+ (unless (db-get db var2 'assigned) ;XXX too conservative?
(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) '()))
@@ -589,7 +587,7 @@
(list
(let loop ((argc argc) (vars vars) (args args))
(cond ((zero? argc) args)
- ((and (not (get db (car vars) 'assigned))
+ ((and (not (db-get db (car vars) 'assigned))
(assoc (cons (car vars) initial-tag) blist))
=>
(lambda (a)
@@ -621,7 +619,7 @@
(and (pair? type)
(eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
- ((if strict-variable-types report-error report)
+ ((if strict report-error report)
loc
(sprintf
"assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
@@ -630,11 +628,11 @@
(when (and (not type) ;XXX global declaration could allow this
(not b)
(not (eq? '* rt))
- (not (get db var 'unknown)))
- (and-let* ((val (or (get db var 'value)
- (get db var 'local-value))))
+ (not (db-get db var 'unknown)))
+ (and-let* ((val (or (db-get db var 'value)
+ (db-get db var 'local-value))))
(when (and (eq? val (first subs))
- (or (not (variable-visible? var))
+ (or (not (variable-visible? var block-compilation))
(not (eq? (variable-mark var '##compiler#inline)
'no))))
(let ((rtlst (list (cons #f (tree-copy rt)))))
@@ -648,7 +646,7 @@
(mark-variable var '##compiler#type rt))))))
(when b
(cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
- #;(strict-variable-types
+ #;(strict
(let ((ot (or (blist-type var flow) (cdr b))))
;;XXX compiler-syntax for "map" will introduce
;; assignments that trigger this warning, so this
@@ -661,8 +659,7 @@
var ot rt)
#t)))))
;; don't use "add-to-blist" since the current operation does not affect aliases
- (let ((t (if (or strict-variable-types
- (not (get db var 'captured)))
+ (let ((t (if (or strict (not (db-get db var 'captured)))
rt
'*))
(fl (car flow)))
@@ -708,7 +705,7 @@
(let-values (((r specialized?)
(call-result n args e loc params typeenv)))
(define (smash)
- (when (and (not strict-variable-types)
+ (when (and (not strict)
(or (not pn)
(and
(not (variable-mark pn '##compiler#pure))
@@ -733,7 +730,7 @@
(oparg? (eq? arg (first subs)))
(pred (and pt
ctags
- (not (get db var 'assigned))
+ (not (db-get db var 'assigned))
(not oparg?))))
(cond (pred
;;XXX is this needed? "typeenv" is the te of "args",
@@ -762,7 +759,7 @@
(if (type<=? t argr)
t
argr)))
- ((get db var 'assigned) '*)
+ ((db-get db var 'assigned) '*)
((type<=? (cdr a) argr) (cdr a))
(else argr))))
(d " assuming: ~a -> ~a (flow: ~a)"
@@ -807,7 +804,7 @@
(length rt))))
(when (and (second params)
(not (type<=? t (first rt))))
- ((if strict-variable-types report-error report-notice)
+ ((if strict report-error report-notice)
loc
(sprintf
"expression returns a result of type `~a', but is declared to return `~a', which is not a subtype"
@@ -820,15 +817,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-concatenate
- (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)
@@ -862,7 +860,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)))
@@ -1807,13 +1805,11 @@
;;; type-db processing
-(define (load-type-database name #!optional (path (repository-path)))
+(define (load-type-database name specialize #!optional (path (repository-path)))
(define (clean! name)
- (when enable-specialization
- (mark-variable name '##compiler#clean #t)))
+ (when specialize (mark-variable name '##compiler#clean #t)))
(define (pure! name)
- (when enable-specialization
- (mark-variable name '##compiler#pure #t)))
+ (when specialize (mark-variable name '##compiler#pure #t)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
(debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))
(fluid-let ((scrutiny-debug #f))
@@ -1867,14 +1863,14 @@
(read-file dbfile))
#t)))
-(define (emit-type-file filename db)
- (with-output-to-file filename
+(define (emit-type-file source-file type-file db block-compilation)
+ (with-output-to-file type-file
(lambda ()
(print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
- source-filename "\n")
+ source-file "\n")
(##sys#hash-table-for-each
(lambda (sym plist)
- (when (and (variable-visible? sym)
+ (when (and (variable-visible? sym block-compilation)
(variable-mark sym '##compiler#declared-type))
(let ((specs (or (variable-mark sym '##compiler#specializations) '()))
(type (variable-mark sym '##compiler#type))
@@ -2353,3 +2349,4 @@
(else
(restore)
(loop (cdr ts) ok))))))
+)
\ No newline at end of file
diff --git a/support.scm b/support.scm
index d91f53b2..da31c4bb 100644
--- a/support.scm
+++ b/support.scm
@@ -25,24 +25,69 @@
; 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) )
+
+(module support
+ (compiler-cleanup-hook bomb collected-debugging-output debugging
+ debugging-chicken 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 reset-profile-info-vector-name!
+ profiling-prelude-exps db-get db-get-all db-put! collect! db-get-list
+ get-line get-line-2 display-line-number-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
+ make-foreign-callback-stub foreign-callback-stub?
+ foreign-callback-stub-id foreign-callback-stub-name
+ foreign-callback-stub-qualifiers foreign-callback-stub-return-type
+ foreign-callback-stub-argument-types register-foreign-callback-stub!
+ foreign-callback-stubs ; should not be exported
+ foreign-type-check foreign-type-convert-result
+ foreign-type-convert-argument final-foreign-type
+ register-foreign-type! lookup-foreign-type clear-foreign-type-table!
+ 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
+ clear-real-name-table! get-real-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
+
+ ;; XXX: These are evil globals that were too hairy to get rid of.
+ ;; These values are set! by compiler and batch-driver, and read
+ ;; in a lot of other places.
+ number-type unsafe)
+
+(import chicken scheme foreign data-structures srfi-1 files extras ports)
-
-(include "compiler-namespace")
(include "tweaks")
(include "banner")
-(declare
- (not inline compiler-cleanup-hook ##sys#user-read-hook) )
-
+;; Evil globals
+(define number-type 'generic)
+(define unsafe #f)
;;; 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 +145,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 +168,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 +178,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 +194,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 +217,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 +244,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 +254,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 +347,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 +365,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
@@ -328,6 +379,12 @@
;;; Profiling instrumentation:
+(define profile-info-vector-name #f)
+(define (reset-profile-info-vector-name!)
+ (set! profile-info-vector-name (make-random-name 'profile-info)))
+
+(define profile-lambda-list '())
+(define profile-lambda-index 0)
(define (expand-profile-lambda name llist body)
(let ([index profile-lambda-index]
@@ -340,49 +397,34 @@
(##core#lambda () (##sys#apply (##core#lambda ,llist ,body) ,args))
(##core#lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )
+;; Get expressions which initialize and populate the profiling vector
+(define (profiling-prelude-exps profile-name)
+ `((set! ,profile-info-vector-name
+ (##sys#register-profile-info
+ ',(length profile-lambda-list)
+ ',profile-name))
+ ,@(map (lambda (pl)
+ `(##sys#set-profile-info-vector!
+ ,profile-info-vector-name
+ ',(car pl)
+ ',(cdr pl) ) )
+ profile-lambda-list)))
;;; Database operations:
-;
-; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level
-; symbol-keyed hash-tables here.
-; - does currently nothing after the first invocation, but we leave it
-; this way to have the option to add default entries for each new db.
-(define initialize-analysis-database
- (let ((initial #t))
- (lambda ()
- (when initial
- (for-each
- (lambda (s)
- (mark-variable s '##compiler#intrinsic 'standard)
- (when (memq s foldable-bindings)
- (mark-variable s '##compiler#foldable #t)))
- standard-bindings)
- (for-each
- (lambda (s)
- (mark-variable s '##compiler#intrinsic 'extended)
- (when (memq s foldable-bindings)
- (mark-variable s '##compiler#foldable #t)))
- extended-bindings)
- (for-each
- (lambda (s)
- (mark-variable s '##compiler#intrinsic 'internal))
- internal-bindings))
- (set! initial #f))))
-
-(define (get db key prop)
+(define (db-get db key prop)
(let ((plist (##sys#hash-table-ref db key)))
(and plist
(let ([a (assq prop plist)])
(and a (##sys#slot a 1)) ) ) ) )
-(define (get-all db key . props)
+(define (db-get-all db key . props)
(let ((plist (##sys#hash-table-ref db key)))
(if plist
(filter-map (lambda (prop) (assq prop plist)) props)
'() ) ) )
-(define (put! db key prop val)
+(define (db-put! db key prop val)
(let ([plist (##sys#hash-table-ref db key)])
(if plist
(let ([a (assq prop plist)])
@@ -398,24 +440,15 @@
[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)))
+(define (db-get-list db key prop) ; returns '() if not set
+ (let ((x (db-get db key prop)))
(or x '())))
;;; Line-number database management:
(define (get-line exp)
- (get ##sys#line-number-database (car exp) exp) )
+ (db-get ##sys#line-number-database (car exp) exp) )
(define (get-line-2 exp)
(let* ((name (car exp))
@@ -431,72 +464,6 @@
##sys#line-number-database) )
-;;; Display analysis database:
-
-(define display-analysis-database
- (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
- (assigned-locally . stl)
- (contractable . con) (standard-binding . stb) (simple . sim)
- (inlinable . inl)
- (collapsable . col) (removable . rem) (constant . con)
- (inline-target . ilt) (inline-transient . itr)
- (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
- (inline-export . ilx) (hidden-refs . hrf)
- (value-ref . vvf)
- (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
- (omit #f))
- (lambda (db)
- (unless omit
- (set! omit
- (append default-standard-bindings
- default-extended-bindings
- internal-bindings) ) )
- (##sys#hash-table-for-each
- (lambda (sym plist)
- (let ([val #f]
- (lval #f)
- [pval #f]
- [csites '()]
- [refs '()] )
- (unless (memq sym omit)
- (write sym)
- (let loop ((es plist))
- (if (pair? es)
- (begin
- (case (caar es)
- ((captured assigned boxed global contractable standard-binding assigned-locally
- collapsable removable undefined replacing unused simple inlinable inline-export
- has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
- (printf "\t~a" (cdr (assq (caar es) names))) )
- ((unknown)
- (set! val 'unknown) )
- ((value)
- (unless (eq? val 'unknown) (set! val (cdar es))) )
- ((local-value)
- (unless (eq? val 'unknown) (set! lval (cdar es))) )
- ((potential-value)
- (set! pval (cdar es)) )
- ((replacable home contains contained-in use-expr closure-size rest-parameter
- captured-variables explicit-rest)
- (printf "\t~a=~s" (caar es) (cdar es)) )
- ((references)
- (set! refs (cdar es)) )
- ((call-sites)
- (set! csites (cdar es)) )
- (else (bomb "Illegal property" (car es))) )
- (loop (cdr es)) ) ) )
- (cond [(and val (not (eq? val 'unknown)))
- (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
- [(and lval (not (eq? val 'unknown)))
- (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
- [(and pval (not (eq? val 'unknown)))
- (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
- (when (pair? refs) (printf "\trefs=~s" (length refs)))
- (when (pair? csites) (printf "\tcss=~s" (length csites)))
- (newline) ) ) )
- db) ) ) )
-
-
;;; Node creation and -manipulation:
;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
@@ -679,8 +646,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,41 +672,42 @@
(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)])
+ (let ((rlist (map cons vars aliases)))
(define (rename v rl) (alist-ref v rl eq? v))
(define (walk n rl)
- (let ([subs (node-subexpressions n)]
- [params (node-parameters n)]
- [class (node-class n)] )
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
(case class
((quote)
(make-node class params '()))
- [(##core#variable)
+ ((##core#variable)
(let ((var (first params)))
- (when (get db var 'contractable)
+ (when (db-get db var 'contractable)
(cfk var))
- (varnode (rename var rl))) ]
- [(set!)
+ (varnode (rename var rl))) )
+ ((set!)
(make-node
'set! (list (rename (first params) rl))
- (list (walk (first subs) rl)) ) ]
- [(let)
+ (list (walk (first subs) rl)) ) )
+ ((let)
(let* ((v (first params))
(val1 (walk (first subs) rl))
(a (gensym v))
(rl2 (alist-cons v a rl)) )
- (put! db a 'inline-transient #t)
+ (db-put! db a 'inline-transient #t)
(make-node
'let (list a)
- (list val1 (walk (second subs) rl2)))) ]
- [(##core#lambda)
- (decompose-lambda-list
+ (list val1 (walk (second subs) rl2)))) )
+ ((##core#lambda)
+ (##sys#decompose-lambda-list
(third params)
(lambda (vars argc rest)
(let* ((as (map (lambda (v)
(let ((a (gensym v)))
- (put! db v 'inline-transient #t)
+ (db-put! db v 'inline-transient #t)
a))
vars) )
(rl2 (append (map cons vars as) rl)) )
@@ -747,10 +716,12 @@
(list (gensym 'f) (second params) ; new function-id
(build-lambda-list as argc (and rest (rename rest rl2)))
(fourth params) )
- (map (cut walk <> rl2) subs) ) ) ) ) ]
- [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) )
+ (map (cut walk <> rl2) subs) ) ) ) ) )
+ (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,12 +744,14 @@
(let walk ((x x))
(make-node (car x) (cadr x) (map walk (cddr x)))))
-(define (emit-global-inline-file filename db)
+;; Only used in batch-driver.scm
+(define (emit-global-inline-file source-file inline-file db
+ block-compilation inline-limit)
(let ((lst '())
(out '()))
(##sys#hash-table-for-each
(lambda (sym plist)
- (when (variable-visible? sym)
+ (when (variable-visible? sym block-compilation)
(and-let* ((val (assq 'local-value plist))
((not (node? (variable-mark sym '##compiler#inline-global))))
((let ((val (assq 'value plist)))
@@ -786,21 +759,21 @@
(not (eq? 'unknown (cdr val))))))
((assq 'inlinable plist))
(lparams (node-parameters (cdr val)))
- ((not (get db sym 'hidden-refs)))
+ ((not (db-get db sym 'hidden-refs)))
((case (variable-mark sym '##compiler#inline)
((yes) #t)
((no) #f)
(else
- (< (fourth lparams) inline-max-size) ) ) ) )
+ (< (fourth lparams) inline-limit) ) ) ) )
(set! lst (cons sym lst))
(set! out (cons (list sym (node->sexpr (cdr val))) out)))))
db)
(if (null? out)
- (delete-file* filename)
- (with-output-to-file filename
+ (delete-file* inline-file)
+ (with-output-to-file inline-file
(lambda ()
(print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
- source-filename "\n")
+ source-file "\n")
(for-each
(lambda (x)
(pp x)
@@ -811,6 +784,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 +800,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 +851,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 +871,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 +881,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 +891,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))
@@ -935,77 +909,53 @@
(debugging 'o "hiding nonexported module bindings" sym)
(hide-variable sym))))
-
-;;; Compute general statistics from analysis database:
-;
-; - Returns:
-;
-; current-program-size
-; original-program-size
-; number of known variables
-; number of known procedures
-; number of global variables
-; number of known call-sites
-; number of database entries
-; average bucket load
-
-(define (compute-database-statistics db)
- (let ((nprocs 0)
- (nvars 0)
- (nglobs 0)
- (entries 0)
- (nsites 0) )
- (##sys#hash-table-for-each
- (lambda (sym plist)
- (for-each
- (lambda (prop)
- (set! entries (+ entries 1))
- (case (car prop)
- ((global) (set! nglobs (+ nglobs 1)))
- ((value)
- (set! nvars (+ nvars 1))
- (if (eq? '##core#lambda (node-class (cdr prop)))
- (set! nprocs (+ nprocs 1)) ) )
- ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
- plist) )
- db)
- (values current-program-size
- original-program-size
- nvars
- nprocs
- nglobs
- nsites
- entries) ) )
-
-(define (print-program-statistics db)
- (receive
- (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
- (when (debugging 's "program statistics:")
- (printf "; program size: \t~s \toriginal program size: \t~s\n" size osize)
- (printf "; variables with known values: \t~s\n" kvars)
- (printf "; known procedures: \t~s\n" kprocs)
- (printf "; global variables: \t~s\n" globs)
- (printf "; known call sites: \t~s\n" sites)
- (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)) ) )
-
+;;; Foreign callback stub and type tables:
+
+(define foreign-callback-stubs '())
+
+(define-record-type foreign-callback-stub
+ (make-foreign-callback-stub id name qualifiers return-type argument-types)
+ foreign-callback-stub?
+ (id foreign-callback-stub-id) ; symbol
+ (name foreign-callback-stub-name) ; string
+ (qualifiers foreign-callback-stub-qualifiers) ; string
+ (return-type foreign-callback-stub-return-type) ; type-specifier
+ (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
+
+(define (register-foreign-callback-stub! id params)
+ (set! foreign-callback-stubs
+ (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
+ ;; mark to avoid leaf-routine optimization
+ (mark-variable id '##compiler#callback-lambda))
+
+(define-constant foreign-type-table-size 301)
+
+(define foreign-type-table #f)
+
+(define (clear-foreign-type-table!)
+ (if foreign-type-table
+ (vector-fill! foreign-type-table '())
+ (set! foreign-type-table (make-vector foreign-type-table-size '())) ))
+
+;; Register a foreign type under the given alias. type is the foreign
+;; type's name, arg and ret are the *names* of conversion procedures
+;; when this type is used as argument or return value, respectively.
+;; The latter two must either both be supplied, or neither.
+;; TODO: Maybe create a separate record type for foreign types?
+(define (register-foreign-type! alias type #!optional arg ret)
+ (##sys#hash-table-set! foreign-type-table alias
+ (vector type (and ret arg) (and arg ret))))
+
+;; Returns either #f (if t does not exist) or a vector with the type,
+;; the *name* of the argument conversion procedure and the *name* of
+;; the return value conversion procedure. If no conversion procedures
+;; have been supplied, the corresponding slots will be #f.
+(define (lookup-foreign-type t)
+ (##sys#hash-table-ref foreign-type-table t))
;;; 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)
@@ -1014,27 +964,27 @@
(follow-without-loop
type
(lambda (t next)
- (let repeat ([t t])
+ (let repeat ((t t))
(case t
- [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
- [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
- (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
- [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
- [(blob scheme-pointer)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ ((char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param)))
+ ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
+ (if unsafe param `(##sys#foreign-fixnum-argument ,param)))
+ ((float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param)))
+ ((blob scheme-pointer)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
,(if unsafe
tmp
`(##sys#foreign-block-argument ,tmp) )
- '#f) ) ) ]
- [(nonnull-scheme-pointer nonnull-blob)
+ '#f) ) ) )
+ ((nonnull-scheme-pointer nonnull-blob)
(if unsafe
param
- `(##sys#foreign-block-argument ,param) ) ]
+ `(##sys#foreign-block-argument ,param) ) )
((pointer-vector)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
,(if unsafe
tmp
@@ -1044,124 +994,123 @@
(if unsafe
param
`(##sys#foreign-struct-wrapper-argument 'pointer-vector ,param) ) )
- [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ ((u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
,(if unsafe
tmp
`(##sys#foreign-struct-wrapper-argument ',t ,tmp) )
- '#f) ) ) ]
- [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector
+ '#f) ) ) )
+ ((nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector
nonnull-f32vector nonnull-f64vector)
(if unsafe
param
`(##sys#foreign-struct-wrapper-argument
',(##sys#slot (assq t tmap) 1)
- ,param) ) ]
- [(integer long size_t integer32)
- (if unsafe param `(##sys#foreign-integer-argument ,param))]
- [(integer64)
- (if unsafe param `(##sys#foreign-integer64-argument ,param))]
- [(unsigned-integer unsigned-integer32 unsigned-long)
+ ,param) ) )
+ ((integer long size_t integer32)
+ (if unsafe param `(##sys#foreign-integer-argument ,param)))
+ ((integer64)
+ (if unsafe param `(##sys#foreign-integer64-argument ,param)))
+ ((unsigned-integer unsigned-integer32 unsigned-long)
(if unsafe
param
- `(##sys#foreign-unsigned-integer-argument ,param) ) ]
- [(unsigned-integer64)
+ `(##sys#foreign-unsigned-integer-argument ,param) ) )
+ ((unsigned-integer64)
(if unsafe
param
- `(##sys#foreign-unsigned-integer64-argument ,param) ) ]
- [(c-pointer c-string-list c-string-list*)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ `(##sys#foreign-unsigned-integer64-argument ,param) ) )
+ ((c-pointer c-string-list c-string-list*)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
(##sys#foreign-pointer-argument ,tmp)
- '#f) ) ) ]
- [(nonnull-c-pointer)
- `(##sys#foreign-pointer-argument ,param) ]
- [(c-string c-string* unsigned-c-string unsigned-c-string*)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ '#f) ) ) )
+ ((nonnull-c-pointer)
+ `(##sys#foreign-pointer-argument ,param) )
+ ((c-string c-string* unsigned-c-string unsigned-c-string*)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
,(if unsafe
`(##sys#make-c-string ,tmp)
`(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
- '#f) ) ) ]
- [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
+ '#f) ) ) )
+ ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
(if unsafe
`(##sys#make-c-string ,param)
- `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
- [(symbol)
+ `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) )
+ ((symbol)
(if unsafe
`(##sys#make-c-string (##sys#symbol->string ,param))
- `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
- [else
- (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
- => (lambda (t)
- (next (if (vector? t) (vector-ref t 0) t)) ) ]
- [(pair? t)
+ `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) )
+ (else
+ (cond ((and (symbol? t) (lookup-foreign-type t))
+ => (lambda (t) (next (vector-ref t 0)) ) )
+ ((pair? t)
(case (car t)
- [(ref pointer function c-pointer)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ ((ref pointer function c-pointer)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
(##sys#foreign-pointer-argument ,tmp)
- '#f) ) ) ]
- [(instance instance-ref)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ '#f) ) ) )
+ ((instance instance-ref)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
(slot-ref ,param 'this)
- '#f) ) ) ]
- [(scheme-pointer)
- (let ([tmp (gensym)])
- `(let ([,tmp ,param])
+ '#f) ) ) )
+ ((scheme-pointer)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,param))
(if ,tmp
,(if unsafe
tmp
`(##sys#foreign-block-argument ,tmp) )
- '#f) ) ) ]
- [(nonnull-scheme-pointer)
+ '#f) ) ) )
+ ((nonnull-scheme-pointer)
(if unsafe
param
- `(##sys#foreign-block-argument ,param) ) ]
- [(nonnull-instance)
- `(slot-ref ,param 'this) ]
- [(const) (repeat (cadr t))]
- [(enum)
- (if unsafe param `(##sys#foreign-integer-argument ,param))]
- [(nonnull-pointer nonnull-c-pointer)
- `(##sys#foreign-pointer-argument ,param) ]
- [else param] ) ]
- [else param] ) ] ) ) )
- (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )
+ `(##sys#foreign-block-argument ,param) ) )
+ ((nonnull-instance)
+ `(slot-ref ,param 'this) )
+ ((const) (repeat (cadr t)))
+ ((enum)
+ (if unsafe param `(##sys#foreign-integer-argument ,param)))
+ ((nonnull-pointer nonnull-c-pointer)
+ `(##sys#foreign-pointer-argument ,param) )
+ (else param) ) )
+ (else param) ) ) ) ) )
+ (lambda ()
+ (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) )
;;; Compute foreign-type conversions:
-(define (foreign-type-convert-result r t)
- (or (and-let* ([(symbol? t)]
- [ft (##sys#hash-table-ref foreign-type-table t)]
- [(vector? ft)] )
- (list (vector-ref ft 2) r) )
+(define (foreign-type-convert-result r t) ; Used only in compiler.scm
+ (or (and-let* (((symbol? t))
+ (ft (lookup-foreign-type t))
+ (retconv (vector-ref ft 2)) )
+ (list retconv r) )
r) )
-(define (foreign-type-convert-argument a t)
- (or (and-let* ([(symbol? t)]
- [ft (##sys#hash-table-ref foreign-type-table t)]
- [(vector? ft)] )
- (list (vector-ref ft 1) a) )
+(define (foreign-type-convert-argument a t) ; Used only in compiler.scm
+ (or (and-let* (((symbol? t))
+ (ft (lookup-foreign-type t))
+ (argconv (vector-ref ft 1)) )
+ (list argconv a) )
a) )
-(define (final-foreign-type t0)
+(define (final-foreign-type t0) ; Used only in compiler.scm
(follow-without-loop
t0
(lambda (t next)
- (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
- => (lambda (t2)
- (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
- [else t] ) )
- (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )
+ (cond ((and (symbol? t) (lookup-foreign-type t))
+ => (lambda (t2) (next (vector-ref t2 0)) ) )
+ (else t) ) )
+ (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) )
;;; Compute foreign result size:
@@ -1183,20 +1132,19 @@
((float double number integer64 unsigned-integer64)
(words->bytes 4) ) ; possibly 8-byte aligned 64-bit double
(else
- (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
- => (lambda (t2)
- (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
- [(pair? t)
+ (cond ((and (symbol? t) (lookup-foreign-type t))
+ => (lambda (t2) (next (vector-ref t2 0)) ) )
+ ((pair? t)
(case (car t)
- [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
- (words->bytes 3) ]
- [else 0] ) ]
- [else 0] ) ) ) )
- (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
+ ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
+ (words->bytes 3) )
+ (else 0) ) )
+ (else 0) ) ) ) )
+ (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)
@@ -1210,22 +1158,21 @@
((double number integer64 unsigned-integer64)
(words->bytes 2) )
(else
- (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
- => (lambda (t2)
- (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
- [(pair? t)
+ (cond ((and (symbol? t) (lookup-foreign-type t))
+ => (lambda (t2) (next (vector-ref t2 0)) ) )
+ ((pair? t)
(case (car t)
- [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
+ ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
scheme-pointer nonnull-scheme-pointer)
- (words->bytes 1)]
- [else (err t)] ) ]
- [else (err t)] ) ) ) )
- (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
+ (words->bytes 1))
+ (else (err t)) ) )
+ (else (err t)) ) ) ) )
+ (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 +1208,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
@@ -1338,7 +1286,7 @@
;;; Scan expression-node for free variables (that are not in env):
-(define (scan-free-variables node)
+(define (scan-free-variables node block-compilation)
(let ((vars '())
(hvars '()))
@@ -1351,7 +1299,7 @@
(let ((var (first params)))
(unless (memq var e)
(set! vars (lset-adjoin eq? vars var))
- (unless (variable-visible? var)
+ (unless (variable-visible? var block-compilation)
(set! hvars (lset-adjoin eq? hvars var))))))
((set!)
(let ((var (first params)))
@@ -1361,7 +1309,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 +1324,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 +1341,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,40 +1357,52 @@
; <variable-alias> -> <variable>
; <lambda-id> -> <variable> or <variable-alias>
-(define (set-real-name! name rname)
+(define-constant real-name-table-size 997)
+
+(define real-name-table #f)
+
+(define (clear-real-name-table!)
+ (set! real-name-table (make-vector real-name-table-size '())))
+
+(define (set-real-name! name rname) ; Used only in compiler.scm
(##sys#hash-table-set! real-name-table name rname) )
+;; TODO: Find out why there are so many lookup functions for this and
+;; reduce them to the minimum.
+(define (get-real-name name)
+ (##sys#hash-table-ref real-name-table name))
+
;; Arbitrary limit to prevent runoff into exponential behavior
(define real-name-max-depth 20)
(define (real-name var . db)
(define (resolve n)
- (let ([n2 (##sys#hash-table-ref real-name-table n)])
+ (let ((n2 (##sys#hash-table-ref real-name-table n)))
(if n2
(or (##sys#hash-table-ref real-name-table n2)
n2)
n) ) )
- (let ([rn (resolve var)])
- (cond [(not rn) (##sys#symbol->qualified-string var)]
- [(pair? db)
- (let ([db (car db)])
- (let loop ([nesting (list (##sys#symbol->qualified-string rn))]
- [depth 0]
- [container (get db var 'contained-in)] )
+ (let ((rn (resolve var)))
+ (cond ((not rn) (##sys#symbol->qualified-string var))
+ ((pair? db)
+ (let ((db (car db)))
+ (let loop ((nesting (list (##sys#symbol->qualified-string rn)))
+ (depth 0)
+ (container (db-get db var 'contained-in)) )
(cond
- ((> depth real-name-max-depth)
- (string-intersperse (reverse (cons "..." nesting)) " in "))
- (container
- (let ([rc (resolve container)])
- (if (eq? rc container)
- (string-intersperse (reverse nesting) " in ")
- (loop (cons (symbol->string rc) nesting)
- (fx+ depth 1)
- (get db container 'contained-in) ) ) ))
- (else (string-intersperse (reverse nesting) " in "))) ) ) ]
- [else (##sys#symbol->qualified-string rn)] ) ) )
-
-(define (real-name2 var db)
+ ((> depth real-name-max-depth)
+ (string-intersperse (reverse (cons "..." nesting)) " in "))
+ (container
+ (let ((rc (resolve container)))
+ (if (eq? rc container)
+ (string-intersperse (reverse nesting) " in ")
+ (loop (cons (symbol->string rc) nesting)
+ (fx+ depth 1)
+ (db-get db container 'contained-in) ) ) ))
+ (else (string-intersperse (reverse nesting) " in "))) ) ) )
+ (else (##sys#symbol->qualified-string rn)) ) ) )
+
+(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) ) )
@@ -1459,7 +1412,7 @@
(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 +1424,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 +1435,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 +1455,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 +1477,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 +1488,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 +1506,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,19 +1536,22 @@
;;; 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)
+(define (variable-visible? sym block-compilation)
(let ((p (##sys#get sym '##compiler#visibility)))
(case p
((hidden) #f)
((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 +1559,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 +1580,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 +1713,7 @@ Usage: chicken FILENAME OPTION ...
EOF
) )
+;; Same as above
(define (print-debug-options)
(display #<<EOF
@@ -1794,3 +1755,4 @@ Available debugging options:
EOF
))
+)
\ No newline at end of file
diff --git a/tests/apply-test.scm b/tests/apply-test.scm
index 81697a5c..155aa70a 100644
--- a/tests/apply-test.scm
+++ b/tests/apply-test.scm
@@ -1,4 +1,4 @@
-(require-extension srfi-1)
+(require-extension srfi-1 extras)
(define max-argcount ##sys#apply-argument-limit)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 078cb0d3..87b472fb 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -13,6 +13,9 @@
(assert (eq? 'ok (foo)))
+(assert (= 1 (foreign-type-size "char")))
+(let ((bytes-in-a-word (##sys#fudge 7)))
+ (assert (= bytes-in-a-word (foreign-type-size "C_word"))))
;; test hiding of unexported toplevel variables
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index 6d7bd1c8..45b0cd7d 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -298,6 +298,48 @@
(m29-baz))
'foo)
+;; Ensure that the modules system is simply an aliasing mechanism:
+;; Module instantion does not create multiple variable copies.
+
+(module m31 *
+ (import chicken scheme)
+ (define mutation-count 0)
+ (define (internally-mutate!)
+ (set! mutation-count (add1 mutation-count)))
+ (define (get-count)
+ mutation-count))
+
+(module m32 *
+ (import chicken scheme m31)
+ (define (externally-mutate!)
+ (set! mutation-count (add1 mutation-count))))
+
+(import m31 m32)
+(test-equal
+ "initial state"
+ 0 mutation-count)
+
+(internally-mutate!)
+
+(test-equal
+ "After mutating inside defining module"
+ 1 mutation-count)
+
+(set! mutation-count 2)
+
+(test-equal
+ "After mutating outside module"
+ 2 mutation-count)
+
+(externally-mutate!)
+
+(test-equal
+ "After mutation by another module"
+ 3 mutation-count)
+
+(test-equal
+ "Internal getter returns same thing"
+ 3 (get-count))
(test-end "modules")
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index f9df9f82..9752226b 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -34,7 +34,7 @@ Warning: at toplevel:
(scrutiny-tests.scm:25) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a158) (procedure car ((pair a158 *)) a158))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a157) (procedure car ((pair a157 *)) a157))'
Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
Trap