1 | ;;;; chicken.scm - The CHICKEN Scheme compiler (loader/main-module) |
---|
2 | ; |
---|
3 | ; Copyright (c) 2000-2007, Felix L. Winkelmann |
---|
4 | ; Copyright (c) 2008, The Chicken Team |
---|
5 | ; All rights reserved. |
---|
6 | ; |
---|
7 | ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following |
---|
8 | ; conditions are met: |
---|
9 | ; |
---|
10 | ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following |
---|
11 | ; disclaimer. |
---|
12 | ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following |
---|
13 | ; disclaimer in the documentation and/or other materials provided with the distribution. |
---|
14 | ; Neither the name of the author nor the names of its contributors may be used to endorse or promote |
---|
15 | ; products derived from this software without specific prior written permission. |
---|
16 | ; |
---|
17 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS |
---|
18 | ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY |
---|
19 | ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR |
---|
20 | ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR |
---|
21 | ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
22 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
23 | ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR |
---|
24 | ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE |
---|
25 | ; POSSIBILITY OF SUCH DAMAGE. |
---|
26 | |
---|
27 | |
---|
28 | (declare |
---|
29 | (uses srfi-1 match srfi-4 utils files support compiler optimizer driver platform backend) |
---|
30 | (run-time-macros) ) |
---|
31 | |
---|
32 | |
---|
33 | (private compiler |
---|
34 | compiler-arguments |
---|
35 | default-standard-bindings default-extended-bindings side-effecting-standard-bindings |
---|
36 | non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings |
---|
37 | standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false |
---|
38 | installation-home optimization-iterations process-command-line |
---|
39 | file-io-only nonwinding-call/cc debugging |
---|
40 | unit-name insert-timer-checks used-units zap-strings-flag |
---|
41 | foreign-declarations debugging-executable block-compilation line-number-database-size |
---|
42 | target-heap-size target-stack-size |
---|
43 | default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size |
---|
44 | current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables |
---|
45 | rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants |
---|
46 | broken-constant-nodes inline-substitutions-enabled compiler-warning |
---|
47 | direct-call-ids foreign-type-table first-analysis |
---|
48 | initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments |
---|
49 | perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! |
---|
50 | reorganize-recursive-bindings substitution-table simplify-named-call |
---|
51 | perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda* |
---|
52 | transform-direct-lambdas! |
---|
53 | debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list |
---|
54 | string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant? |
---|
55 | collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all |
---|
56 | put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode |
---|
57 | build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects? |
---|
58 | simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list |
---|
59 | pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables |
---|
60 | topological-sort print-version print-usage initialize-analysis-database |
---|
61 | default-declarations units-used-by-default words-per-flonum |
---|
62 | foreign-string-result-reserve parameter-limit default-output-filename eq-inline-operator optimizable-rest-argument-operators |
---|
63 | membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument |
---|
64 | generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration |
---|
65 | foreign-argument-conversion foreign-result-conversion) |
---|
66 | |
---|
67 | |
---|
68 | (include "tweaks") |
---|
69 | |
---|
70 | (eval-when (load) |
---|
71 | (include "chicken-more-macros") |
---|
72 | (include "chicken-ffi-macros") ) |
---|
73 | |
---|
74 | |
---|
75 | ;;; Prefix argument list with default options: |
---|
76 | |
---|
77 | (define compiler-arguments |
---|
78 | (append |
---|
79 | (cdr (argv)) |
---|
80 | (remove (lambda (x) (string=? x "")) (string-split (or (getenv "CHICKEN_OPTIONS") ""))) ) ) |
---|
81 | |
---|
82 | |
---|
83 | ;;; Process command-line options: |
---|
84 | ; |
---|
85 | ; - remove runtime-options ("-:...") |
---|
86 | ; - filter out source-filename |
---|
87 | ; - convert options into symbols (without the initial hyphens) |
---|
88 | |
---|
89 | (define (process-command-line args) |
---|
90 | (let loop ([args args] [options '()] [filename #f]) |
---|
91 | (if (null? args) |
---|
92 | (values filename (reverse options)) |
---|
93 | (let* ([arg (car args)] |
---|
94 | [len (string-length arg)] |
---|
95 | [char0 (string-ref arg 0)] ) |
---|
96 | (if (and (char=? #\- char0) (> len 1)) |
---|
97 | (if (and (> len 1) (char=? #\: (string-ref arg 1))) |
---|
98 | (loop (cdr args) options filename) |
---|
99 | (loop (cdr args) (cons (string->symbol (substring arg 1 len)) options) filename) ) |
---|
100 | (if filename |
---|
101 | (loop (cdr args) (cons arg options) filename) |
---|
102 | (loop (cdr args) options arg) ) ) ) ) ) ) |
---|
103 | |
---|
104 | |
---|
105 | ;;; Run compiler with command-line options: |
---|
106 | |
---|
107 | (receive (filename options) ((or (user-options-pass) process-command-line) compiler-arguments) |
---|
108 | (let loop ([os options]) |
---|
109 | (unless (null? os) |
---|
110 | (let ([o (car os)] |
---|
111 | [rest (cdr os)] ) |
---|
112 | (cond [(eq? 'optimize-level o) |
---|
113 | (let ([level (string->number (car rest))]) |
---|
114 | (case level |
---|
115 | [(0) #f] |
---|
116 | [(1) |
---|
117 | (set! options (cons* 'optimize-leaf-routines options)) ] |
---|
118 | [(2) |
---|
119 | (set! options |
---|
120 | (cons 'optimize-leaf-routines options) ) ] |
---|
121 | [(3) |
---|
122 | (set! options |
---|
123 | (cons* 'optimize-leaf-routines 'unsafe options) ) ] |
---|
124 | [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] ) |
---|
125 | (loop (cdr rest)) ) ] |
---|
126 | [(eq? 'debug-level o) |
---|
127 | (let ([level (string->number (car rest))]) |
---|
128 | (case level |
---|
129 | [(0) (set! options (cons* 'no-lambda-info 'no-trace options))] |
---|
130 | [(1) (set! options (cons 'no-trace options))] |
---|
131 | [(2) #f] |
---|
132 | [else (compiler-warning 'usage "invalid debug level ~S - ignored" (car rest))] ) |
---|
133 | (loop (cdr rest)) ) ] |
---|
134 | [(eq? 'benchmark-mode o) |
---|
135 | (set! options |
---|
136 | (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe |
---|
137 | 'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info |
---|
138 | options) ) |
---|
139 | (loop rest) ] |
---|
140 | [(memq o valid-compiler-options) (loop rest)] |
---|
141 | [(memq o valid-compiler-options-with-argument) |
---|
142 | (if (pair? rest) |
---|
143 | (loop (cdr rest)) |
---|
144 | (quit "missing argument to `-~s' option" o) ) ] |
---|
145 | [else |
---|
146 | (compiler-warning |
---|
147 | 'usage "invalid compiler option `~a' - ignored" |
---|
148 | (if (string? o) o (conc "-" o)) ) |
---|
149 | (loop rest) ] ) ) ) ) |
---|
150 | (apply compile-source-file filename options) |
---|
151 | (exit) ) |
---|