diff -rN -u old-chicken/Makefile.am new-chicken/Makefile.am --- old-chicken/Makefile.am 2005-06-27 19:59:18.000000000 -0500 +++ new-chicken/Makefile.am 2005-07-05 23:53:13.000000000 -0500 @@ -29,7 +29,8 @@ BOOTSTRAP_PATH = . CHICKEN = $(BOOTSTRAP_PATH)/chicken CSI = $(BOOTSTRAP_PATH)/csi -CHICKEN_FLAGS = -quiet -debug-level 0 -optimize-level 2 -include-path $(srcdir) $(CHICKEN_EXTRA_FLAGS) +#CHICKEN_FLAGS = -quiet -debug-level 0 -optimize-level 2 -include-path $(srcdir) $(CHICKEN_EXTRA_FLAGS) +CHICKEN_FLAGS = -quiet -include-path $(srcdir) $(CHICKEN_EXTRA_FLAGS) CHICKEN_UFLAGS = -quiet -debug-level 0 -optimize-level 2 -unsafe -feature unsafe -include-path $(srcdir) DOCFILES = format.txt ChangeLog README LICENSE chicken.html AM_MAKEINFOFLAGS=--no-split @@ -38,7 +39,7 @@ # (suggested by Sven Hartrumpf) INSTALL_SCRIPT = @INSTALL@ -bin_PROGRAMS = chicken chicken-static csi csi-static csc chicken-profile chicken-setup +bin_PROGRAMS = chicken chicken-static csi csi-static csc chicken-profile chicken-setup chicken-parrot man_MANS = chicken.1 csi.1 chicken-config.1 csc.1 chicken-profile.1 chicken-setup.1 @@ -48,6 +49,10 @@ chicken_LDADD = chicken.lo support.lo partition.lo easyffi.lo compiler.lo optimizer.lo c-platform.lo c-backend.lo batch-driver.lo libchicken.la $(MORE_LIBS) chicken_LDFLAGS = $(LINKFLAGS) +chicken_parrot_SOURCES = +chicken_parrot_LDADD = chicken.lo support.lo partition.lo easyffi.lo compiler.lo optimizer.lo parrot-platform.lo parrot-backend.lo parrot-register-alloc.lo batch-driver.lo libchicken.la $(MORE_LIBS) +chicken_parrot_LDFLAGS = $(LINKFLAGS) + chicken_static_SOURCES = chicken_static_LDADD = chicken.o support.o partition.o easyffi.o compiler.o optimizer.o c-platform.o c-backend.o batch-driver.o libchicken.la $(MORE_STATIC_LIBS) chicken_static_LDFLAGS = -static $(LINKFLAGS) diff -rN -u old-chicken/batch-driver.scm new-chicken/batch-driver.scm --- old-chicken/batch-driver.scm 2005-06-27 19:59:18.000000000 -0500 +++ new-chicken/batch-driver.scm 2005-06-27 19:59:19.000000000 -0500 @@ -659,6 +659,10 @@ (begin-time) (receive (node literals lambdas) (prepare-for-code-generation node3 db partitions) + (print-node "prepare-code-generation" '|9| node) + (when (print-header "prepare-code-generation" '|9|) + (pretty-print literals) + (map (lambda (x) (pretty-print (record->vector x)) (dump-nodes (lambda-literal-body x))) lambdas)) (end-time "preparation") (begin-time) diff -rN -u old-chicken/parrot-backend.scm new-chicken/parrot-backend.scm --- old-chicken/parrot-backend.scm 1969-12-31 18:00:00.000000000 -0600 +++ new-chicken/parrot-backend.scm 2005-07-07 20:50:00.000000000 -0500 @@ -0,0 +1,1131 @@ +;;; parrot-backend.scm - Parrot-generating backend for the CHICKEN compiler +; vim: expandtab +; +; Copyright (c) 2005, John Lenz (lenz@cs.wisc.edu) +; All rights reserved. +; +; Based on c-backend.scm written by Felix L. Winkelmann +; +; 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. +; +; Send bugs, suggestions and ideas to: +; +; felix@call-with-current-continuation.org +; lenz@cs.wisc.edu + + +(declare (unit backend)) + +#{compiler + compiler-arguments process-command-line find-early-refs + default-standard-bindings default-extended-bindings side-effecting-standard-bindings + non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings + foldable-extended-bindings + standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false + installation-home optimization-iterations debugging cleanup + foreign-type-table-size file-io-only namespace-table + unit-name insert-timer-checks used-units inlining external-variables + foreign-declarations emit-trace-info block-compilation analysis-database-size line-number-database-size + target-heap-size target-stack-size try-harder default-installation-home target-heap-growth target-heap-shrinkage + default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size + target-initial-heap-size disable-stack-overflow-checking + current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants + rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used + mutable-constants + broken-constant-nodes inline-substitutions-enabled + direct-call-ids foreign-type-table first-analysis block-variable-literal? + initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database + scan-toplevel-assignments + perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations + perform-pre-optimization! + reorganize-recursive-bindings substitution-table simplify-named-call find-inlining-candidates perform-inlining! + perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub + expand-foreign-lambda* + transform-direct-lambdas! target-include-file emit-unsafe-marker + debugging-chicken warnings-enabled bomb check-signature posq stringify symbolify flonum? build-lambda-list + string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant? + collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all + put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode + build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node + expression-has-side-effects? + simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list + pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables + scan-free-variables external-protos-first + topological-sort print-version print-usage initialize-analysis-database + generate-external-variables real-name real-name2 unique-id + compiler-features default-declarations units-used-by-default words-per-flonum + foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators + membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument + default-optimization-iterations generate-foreign-callback-header generate-foreign-callback-stub-prototypes + generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration + foreign-argument-conversion foreign-result-conversion quick-namespace-list setup-quick-namespace-list + namespace-lookup compute-namespace-size} + +;(include "tweaks") +;(cond-expand +; [compiler-unsafe +; (declare +; (fixnum) +; (disable-interrupts) +; (no-bound-checks) +; (no-procedure-checks) +; (no-argc-checks) ) ] +; [else + (declare + (fixnum) + (disable-interrupts) ) + ;] ) + +(declare (uses parrot-register-alloc)) + +; Below is also from tweaks.scm +(define-inline (make-node c p s) (##sys#make-structure 'node c p s)) +(define-inline (node-class n) (##sys#slot n 1)) +(define-inline (node-parameters n) (##sys#slot n 2)) +(define-inline (node-subexpressions n) (##sys#slot n 3)) + +;;; Write atoms to output-port: + +(define output #f) + +(define (gen . data) + (for-each + (lambda (x) + (if (eq? #t x) + (newline output) + (display x output) ) ) + data) ) + +(define (gen-list lst) + (for-each + (lambda (x) (display x output)) + (intersperse lst #\space) ) ) + +(define (gen-assembly-list assembly) + (for-each + (lambda (x) + (when (not (null? x)) + (display (car x) output) + (display " " output) + (for-each + (lambda (y) (display y output)) + (intersperse (cdr x) ", ")) + (newline output))) + assembly)) + +(define unique-label + (let ((count 0)) + (lambda () + (set! count (add1 count)) + (string-append "lbl" (number->string count))))) + +(define (compute-namespace-size n) + 37) ;*** FIX + +(define inline-hash-table (make-hash-table string=?)) + +;;; Check name for namespace: + +(define quick-namespace-list '()) + +(define (setup-quick-namespace-list) + (for-each + (lambda (ns) + (set! quick-namespace-list (append (cdr ns) quick-namespace-list)) ) + namespace-table) ) + +(define (namespace-lookup sym) + (and (memq sym quick-namespace-list) + (let loop ([nslist namespace-table] [i 0]) + (cond [(null? nslist) (bomb "symbol not in namespace" sym)] + [(memq sym (cdar nslist)) i] + [else (loop (cdr nslist) (add1 i))] ) ) ) ) + + +;;; + +(define-record assembly-block + statements ; List of statements, each statement is itself a list + return-reg ; Register this block returns, otherwise #f +) + +(define-record statement + block ; assembly-block for this statement + bind-num ; List of bind numbers (might be more than one because of ##core#setlocal) +) + +(define-record call + if-block ; If this is an if-dependent call, this holds the assembly-block of the check. Otherwise #f + true-function ; List of statements to actually make the call (should only access (local 0 #f) if at all) + true-args ; List of assembly-blocks for the call arguments + false-function ; List of statements to actually make the false call, otherwise #f + false-args ; List of assembly-blocks for the false branch of the if, or empty if no if +) + +;; Debugging functions + +(define (dump-code code) + (for-each + (lambda (x) (gen x #t)) + code)) + +(define (dump-assembly-block block) + (gen "##START OF BLOCK# Returns" (assembly-block-return-reg block) #t) + (dump-code (assembly-block-statements block)) + (gen "##END OF BLOCK" #t #t)) + +(define (dump-statement statement) + (gen "##START OF STATEMENT# Bind " (statement-bind-num statement) #t) + (if statement (dump-assembly-block (statement-block statement))) + (gen "##END OF STATEMENT" #t #t)) + +(define (dump-call call) + (if (call-if-block call) + (begin + (gen "## START OF IF CALL # True side " #t) + (for-each dump-assembly-block (call-true-args call)) + (dump-code (call-true-function call)) + (gen "## False Code" #t) + (for-each dump-assembly-block (call-false-args call)) + (dump-code (call-false-function call))) + (begin + (gen "## START OF CALL" #t) + (for-each dump-assembly-block (call-true-args call)) + (dump-code (call-true-function call)))) + (gen "## END OF CALL" #t #t)) + + +;; Helper functions for manipulating assembly-blocks, statements, and calls + +(define-macro (add-reg-index reg index) + `(begin + (if (third ,reg) + (bomb "Error adding index to register. Already has an index")) + (cons* (first ,reg) (second ,reg) ,index (cdddr ,reg)))) + +(define (reg-replace-array-set? reg code) + (let ((reg-type (first reg)) + (reg-num (second reg))) + (if (or (eq? reg-type 'temp) (eq? reg-type 'save)) + (fold + (lambda (x res) + (and + res + (fold + (lambda (x res) + (and res + (if (and (list? x) + (eq? (first x) reg-type) + (eq? (second x) reg-num)) + (not (third x)) + #t))) + #t + x))) + #t + code) + #f))) + +(define (replace-reg old-reg new code) + (let* ((old-reg-type (first old-reg)) + (old-reg-num (second old-reg)) + (old-reg-decrement? (or (eq? old-reg-type 'save) (eq? old-reg-type 'temp))) + (new-reg-type (first new)) + (new-reg-num (second new)) + (new-reg-index (third new))) + (filter-map + (lambda (statement) ; Map over statements + (if (and new-reg-index (list? statement) (eq? (car statement) 'delete-if-array-set)) + #f ;; Skip this statement + (map (lambda (x) ; Map over arguments + (if (list? x) + (let ((type (first x)) + (num (second x)) + (index (third x))) + (cond ((and (eq? type old-reg-type) + (eq? num old-reg-num)) + (if (and index new-reg-index) + (bomb "Can't replace register because it is already indexed")) + (list new-reg-type new-reg-num (or new-reg-index index))) + ((and old-reg-decrement? (eq? type old-reg-type) (> num old-reg-num)) + (list type (- num 1) index)) + (else + x))) + x)) + (if (and (list? statement) (eq? (car statement) 'delete-if-array-set)) + (cdr statement) + statement)))) + code))) + +;; Swap the two given registers +(define (swap-regs type reg-num-1 reg-num-2 code) + (map (lambda (x) ; Map over statements + (map (lambda (y) ; Map over elements inside the statement + (if (and (list? y) (eq? (car y) type)) + (cond ((= (cadr y) reg-num-1) + (cons* type reg-num-2 (cddr y))) + ((= (cadr y) reg-num-2) + (cons* type reg-num-1 (cddr y))) + (else y)) + y)) + x)) + code)) + +;; Increment all the temp registers by count +(define (increment-regs count type code) + (map (lambda (x) ; Map over statements + (map (lambda (x) ; Map over elements inside the statement + (if (and (list? x) (eq? (car x) type)) + (cons* type (+ count (cadr x)) (cddr x)) + x)) + x)) + code)) + +(define (calc-temp ret) + (if (and ret (eq? (first ret) 'temp) (eq? (second ret) 0)) + (list 'temp 1 #f) + (list 'temp 0 #f))) + +;; Helper function for calculating bind numbers +(define func-check-bind-num #f) +(define (local-reg num argc) + (if (>= num argc) + + ;; Local is a bind + (receive (single? index) (func-check-bind-num num) + (if single? + (list 'bind index #f) + (list 'local index #f))) + + ;; Local is an input argument + (list 'local num #f))) + +;;; Generate target code: + +(define (generate-code literals lambdas out source-file dynamic db file-partition) + (let () + + (define (find-lambda id) + (or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas) + (bomb "can't find lambda" id) ) ) + + ;(define (slashify s) (string-translate (->string s) "\\" "/")) + + (define (find-used-locals node argc) + (let ((params (node-parameters node))) + (case (node-class node) + ((##core#local) + (if (<= (first params) argc) + (list (first params)) + '())) + (else + (append-map (lambda (x) (find-used-locals x argc)) (node-subexpressions node)))))) + + (define (calc-bind-partition node argc) + + (define (walk n single-count multi-count count) + (let ((subs (node-subexpressions n))) + (case (node-class n) + ((##core#bind) ;; Assume (first params) is 1, and bind has two subexpressions + + ;; First, we count the number of uses of this bind + (let ((setlocal (let ((sub-node (first subs))) + (if (eq? (node-class sub-node) '##core#setlocal) + (first (node-parameters sub-node)) + #f)))) + (if setlocal + (receive (s m) (walk (second subs) single-count multi-count (add1 count)) + (values s (cons (cons count setlocal) m))) + + ;; This bind itself is not a setlocal. But before we can say this bind is single-use, + ;; we need to check if the bind would cross another setlocal. + + (let* ((used-locals (find-used-locals n argc)) + (num-users + (letrec ((loop + (lambda (n rest) + (case (node-class n) + ((##core#local) + (let ((num (first (node-parameters n)))) + (if (= num count) + (add1 rest) + rest))) + ((##core#setlocal) + (let ((num (first (node-parameters n)))) + ;; If this local is used by the bind, then set the number of users to 2 + (if (member num used-locals) + (+ 2 rest) + rest))) + (else + (fold loop rest (node-subexpressions n))))))) + (loop (second subs) 0)))) + (cond + ((= num-users 0) + (receive (s m) (walk (second subs) single-count multi-count (add1 count)) + (values s (cons (cons count #f) m)))) + ((= num-users 1) + (receive (s m) (walk (second subs) (add1 single-count) multi-count (add1 count)) + (values (cons (cons count single-count) s) m))) + (else + (receive (s m) (walk (second subs) single-count (add1 multi-count) (add1 count)) + (values s (cons (cons count multi-count) m))))))))) + + (else + (let loop ((lst subs)) + (if (null? lst) + (values '() '()) + (receive (s m) (walk (car lst) single-count multi-count count) + (receive (s2 m2) (loop (cdr lst)) + (values (append s s2) (append m m2)))))))))) + (walk node 0 argc argc)) + + (define (expression node bind-start ll) + (let ((single-binds '()) + (multi-binds '())) + + (define (expr n bind-count) + (display " expression ") (display (node-class n)) (newline) + (let ((subs (node-subexpressions n)) + (params (node-parameters n)) ) + (case (node-class n) + + ((##core#immediate) + (make-assembly-block + (case (first params) + ((bool) (if (second params) + '(("new" (temp 0 #f) ".Boolean") ("set" (temp 0 #f) "1")) + '(("new" (temp 0 #f) ".Boolean")))) + ((char) + `(("new" (temp 0 #f) ".String") + ("set" (temp 0 #f) ,(string-append "\"" (second params) "\"")))) + ((nil) '(("find_type" (I 0 #f) "\"SchemeEndOfList\"") + ("new" (temp 0 #f) (I 0 #f)))) + ((fix) + `(("new" (temp 0 #f) ".Integer") + ("set" (temp 0 #f) ,(number->string (second params))))) + ((eof) '(("find_type" (I 0 #f) "\"SchemeEndOfFile\"") + ("new" (temp 0 #f) (I 0 #f)))) + (else (bomb "bad immediate")) ) + '(temp 0 #f))) + + ((##core#literal) + (make-assembly-block + `(("set" (temp 0 #f) (lf 0 ,(first params)))) + '(temp 0 #f))) + + ((if) + (let ((true-call (expr (cadr subs) bind-count)) + (false-call (expr (caddr subs) bind-count))) + (make-call + (expr (car subs) bind-count) + (call-true-function true-call) + (call-true-args true-call) + (call-true-function false-call) + (call-true-args false-call)))) + + ((##core#proc) + (make-assembly-block + `(("set_addr" (I 0 #f) ,(first params)) + (delete-if-array-set "new" (temp 0 #f) ".Integer") + ("set" (temp 0 #f) (I 0 #f))) + '(temp 0 #f))) + ;(if (and (pair? (cdr params)) (cadr params)) "" (prefix-id)) + + ((##core#bind) + ;; Assume (first params) is 1, and the bind has two subexpressions + (let ((bind (car subs)) + (rest (second subs))) + (receive (single? index) (func-check-bind-num bind-count) + (if single? + (set! single-binds + (cons + (make-statement + (expr bind (add1 bind-count)) + index) + single-binds)) + (set! multi-binds + (cons + (make-statement + (expr bind (add1 bind-count)) + index) + multi-binds)))) + + (expr rest (add1 bind-count)))) + + ((##core#ref) + (let* ((n (expr (car subs) bind-count)) + (ret (assembly-block-return-reg n))) + (if (not ret) + (bomb "Ref expression does not return a value")) + (if (and (list? ret) (eq? (car ret) 'temp)) + ;; Can use the already returned temporary + (make-assembly-block + (append + (assembly-block-statements n) + `(("set" ,ret ,(add-reg-index ret (first params))))) + ret) + ;; Means we are referencing a local, so need to create a temprorary register + (make-assembly-block + (append + (assembly-block-statements n) + `(("set" (temp 0 #f) ,(add-reg-index ret (first params))))) + '(temp 0 #f))))) + + ((##core#unbox) + (let* ((n (expr (car subs) bind-count)) + (ret (assembly-block-return-reg n))) + (if (not ret) + (bomb "Unbox expression does not return a value")) + (if (and (list? ret) (eq? (car ret) 'temp)) + ;; Can use the already returned temporary + (make-assembly-block + (append + (assembly-block-statements n) + `(("deref" ,ret ,ret))) + ret) + ;; Means we are referencing a local, so need to create a temprorary register + (make-assembly-block + (append + (assembly-block-statements n) + `(("deref" (temp 0 #f) ,ret))) + '(temp 0 #f))))) + + ((##core#update_i ##core#update) + (bomb "##core#update not supported")) + ;(gen "C_set_block_item(") + ;(expr (car subs) i) + ;(gen #\, (first params) #\,) + ;(expr (cadr subs) i) + ;(gen #\)) + + ;((##core#update) + ; (gen "C_mutate(((C_word *)") + ; (expr (car subs) i) + ; (gen ")+" (+ (first params) 1) ",") + ; (expr (cadr subs) i) + ; (gen #\)) ) + + ((##core#updatebox_i ##core#updatebox) + (let* ((box (expr (car subs) bind-count)) + (value (expr (cadr subs) bind-count)) + (box-ret (assembly-block-return-reg box)) + (value-ret (assembly-block-return-reg value)) + (value-ret-temp (and value-ret (eq? (car value-ret) 'temp))) + (value-ret-save (and value-ret (eq? (car value-ret) 'save)))) + (if (or (not box-ret) (not value-ret)) + (bomb "Updatebox does not return a value")) + + (make-assembly-block + + (append + ;; Value block returns its result in (save 0) register... if not, swap so it does + (cond + (value-ret-temp + (replace-reg value-ret '(save 0 #f) (increment-regs 1 'save (assembly-block-statements value)))) + (value-ret-save + (swap-regs 'save 0 (cadr value-ret) (assembly-block-statements value))) + (else + (assembly-block-statements value))) + + (if (or value-ret-temp value-ret-save) + ;; Increment the number of saves used in box, so that (save 1) is preserved + (increment-regs 1 'save (assembly-block-statements box)) + ;; Value is returned in a local, can be used directly + (assembly-block-statements box)) + + `(("setref" ,box-ret ,(if (or value-ret-temp value-ret-save) (list 'save 0 #f) value-ret)))) + + box-ret))) + + ((##core#closure) + (let* ((assembly-subs (map (lambda (x) (expr x bind-count)) subs))) + (make-assembly-block + (cons '("new" (save 0 #f) ".FixedPMCArray # Closure") + (cons `("set" (save 0 #f) ,(number->string (first params))) + (append-map + (lambda (n count) + (let* ((ret (assembly-block-return-reg n)) + (inc-ret (if (and ret (eq? (car ret) 'save)) + (list 'save (add1 (cadr ret)) (third ret)) + ret))) + (if (not ret) + (bomb "Closure argument does not return a value")) + (if (reg-replace-array-set? ret (assembly-block-statements n)) + (replace-reg ret + `(save 0 ,count) + (increment-regs 1 'save (assembly-block-statements n))) + (append + (increment-regs 1 'save (assembly-block-statements n)) + `(("set" (save 0 ,count) ,ret)))))) + assembly-subs + (iota (length assembly-subs) 0)))) + (list 'save 0 #f)))) + + ((##core#box) + (let* ((n (expr (car subs) bind-count)) + (ret (assembly-block-return-reg n)) + (temp (calc-temp ret))) + (if (not ret) + (bomb "Unbox expression does not return a value")) + (make-assembly-block + (append + (assembly-block-statements n) + `(("new" ,temp ".Ref") + ("setref" ,temp ,ret))) + temp))) + ;(gen "(*a=C_VECTOR_TYPE|1,a[1]=") + ;(expr (car subs) i) + ;(gen ",tmp=(C_word)a,a+=2,tmp)") + + ((##core#local) + (let ((reg (local-reg (first params) (lambda-literal-argument-count ll)))) + (if (third reg) ;; If it is indexed (this is no longer neccissary of parrot gets variable sized register frames) + (make-assembly-block + `(("set" (temp 0 #f) ,reg)) + '(temp 0 #f)) + (make-assembly-block + '() + reg)))) + ;(gen #\t (first params)) + + ((##core#setlocal) + (expr (car subs) bind-count)) + + ((##core#global) + (let ([index (first params)] + [safe (second params)] + [block (third params)] ) + (make-assembly-block + (cons + `("set" (temp 0 #f) (lf 0 ,index)) + (cond [block + (if safe + '() + `(("set" "S0" ,(c-ify-string (symbol->string (fourth params)))) + ("isnull" (temp 0 #f) "bad_global_access"))) ] + [safe + '(("deref" (temp 0 #f) (temp 0 #f))) ] + [else + '(("deref" (temp 0 #f) (temp 0 #f)) + ("set" "S0" "\"\"") + ("isnull" (temp 0 #f) "bad_global_access")) ] )) + (list 'temp 0 #f)))) + + ((##core#setglobal ##core#setglobal_i) + (let* ([index (first params)] + [block (second params)] + [n (expr (car subs) bind-count) ] + [ret (assembly-block-return-reg n) ] + [temp (calc-temp ret) ] ) + (if (not ret) + (bomb "Setglobal does not return an expression")) + (make-assembly-block + (append + (assembly-block-statements n) + (if block + `(("set" (lf 0 ,index) ,ret)) + `(("set" ,temp (lf 0 ,index)) + ("setref" ,temp ,ret)))) + ret))) + + ((##core#undefined) + (make-assembly-block + '(("null " (temp 0 #f))) + (list 'temp 0 #f))) + + ((##core#call) + (let* ((args (cdr subs)) + ;(n (length args)) + ;(nc i) + ;(nf (add1 n)) + ;(p2 (pair? (cdr params))) + ;(name (and p2 (second params))) + ;(call-id (and p2 (pair? (cddr params)) (third params))) + ;(customizable (and call-id (fourth params))) + ;(empty-closure (and customizable (zero? (lambda-literal-closure-size (find-lambda call-id))))) + (fn (car subs)) ) + ;(when (and emit-trace-info name) (gen #t "C_trace(\"" (slashify name) "\");")) + (cond + ; Don't optimize for inline ##proc, since the assmebly code will be the same + ;((eq? '##core#proc (node-class fn)) + ; (let ([fpars (node-parameters fn)]) + ; (gen #t + ; (if (and (pair? (cdr fpars)) (cadr fpars)) + ; "" + ; (prefix-id) ) + ; (first fpars) + ; #\( nf ",0,") ) + ; (expr-args args i) + ; (gen ");") ) + + ; Skip the call-id stuff + ;(call-id + ; (cond ((and (eq? call-id (lambda-literal-id ll)) + ; (lambda-literal-looping ll) ) + ; (let* ([temps (lambda-literal-temporaries ll)] + ; [ts (iota n (+ temps nf) 1)] ) + ; (for-each + ; (lambda (arg tr) + ; (gen #t #\t tr #\=) + ; (expr arg i) + ; (gen #\;) ) + ; args ts) + ; (for-each + ; (lambda (from to) (gen #t #\t to "=t" from #\;)) + ; ts (iota n 1 1) ) + ; (unless customizable (gen #t "c=" nf #\;)) + ; (gen #t "goto loop;") ) ) + ; (else + ; (unless empty-closure + ; (gen #t #\t nc #\=) + ; (expr fn i) + ; (gen #\;) ) + ; (gen #t (prefix-id) call-id #\() + ; (unless customizable (gen nf #\,)) + ; (unless empty-closure (gen #\t nc #\,)) + ; (expr-args args i) + ; (gen ");") ) ) ) + (else + (make-call + #f + '(("jump" (local 0 #f))) + (cons + (expr fn bind-count) + (map (lambda (x) (expr x bind-count)) args)) + #f + #f))))) + + ((##core#recurse) + (let* (;[n (length subs)] + ;[nf (add1 n)] + ;[tailcall (first params)] Doesn't matter, everything is essiantally a tail call + [call-id (second params)] + [empty-closure (zero? (lambda-literal-closure-size ll))] ) + (cond ;(tailcall + ; (let* ([temps (lambda-literal-temporaries ll)] + ; [ts (iota n (+ temps nf) 1)] ) + ; (for-each + ; (lambda (arg tr) + ; (gen #t #\t tr #\=) + ; (expr arg i) + ; (gen #\;) ) + ; subs ts) + ; (for-each + ; (lambda (from to) (gen #t #\t to "=t" from #\;)) + ; ts (iota n 1 1) ) + ; (gen #t "goto loop;") ) ) + (else + (make-call + #f + `(("branch" ,call-id)) + + (if empty-closure + (map (lambda (x) (expr x bind-count)) subs) + (cons + (make-assembly-block + '() + (list 'local 0 #f)) + (map (lambda (x) (expr x bind-count)) subs))) + #f + #f))))) + + ((##core#direct_call) + (let* ((args (cdr subs)) + ;(n (length args)) + ;(nf (add1 n)) + ;(name (second params)) + (call-id (third params)) + ;(demand (fourth params)) + ;(allocating (not (zero? demand))) + (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))) + (make-call + #f + `(("branch" ,call-id)) + + (if empty-closure + (map (lambda (x) (expr x bind-count)) (cdr subs)) + (map (lambda (x) (expr x bind-count)) subs)) + #f + #f))) + + ((##core#callunit) + (warning "callunit not implemented") + (make-call + #f + `(("load_bytecode" ,(string-append "\"" (first params) "\""))) + (cons + (make-assembly-block + '(("null" (temp 0 #f))) + '(temp 0 #f)) + (map (lambda (x) (expr x bind-count)) subs)) + #f + #f)) + ;; The code generated here does not use the extra temporary needed for standard calls, so we have + ;; one unused varable: + ;(let* ((n (length subs)) + ; (nf (+ n 1)) ) + ; (gen #t "C_" (first params) "_toplevel(" nf ",C_SCHEME_UNDEFINED,") + ; (expr-args subs i) + ; (gen ");") ) + + ((##core#return) + (bomb "##core#return not implemented")) + ;(gen #t "return(") + ;(expr (first subs) i) + ;(gen ");") + + ((##core#inline ##core#inline_allocate) + (let ((func (hash-table-ref inline-hash-table (first params)))) + (if func + (func (lambda (x) (expr x bind-count)) subs) + (begin + (warning (string-append "inline " (first params) " is not supported")) + (make-assembly-block + '(("new" (temp 0 #f) ".Undef")) + '(temp 0 #f)))))) + ;(gen "(C_word)" (first params) #\() + ;(expr-args subs i) + ;(gen #\)) + + ;((##core#inline_allocate) + ; (gen "(C_word)" (first params) "(&a," (length subs)) + ; (if (pair? subs) + ; (begin + ; (gen #\,) + ; (expr-args subs i) ) ) + ; (gen #\)) ) + + ((##core#inline_ref) + (bomb "ffi not supported")) + ;(gen (foreign-result-conversion (second params) "a") (first params) #\)) + + ((##core#inline_update) + (bomb "ffi not supported")) + ;(let ([t (second params)]) + ; (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t)) + ; (expr (first subs) i) + ; (gen "),C_SCHEME_UNDEFINED)") ) + + ((##core#inline_loc_ref) + (bomb "ffi not supported")) + ;(let ([t (first params)]) + ; (gen (foreign-result-conversion t "a") "*((" (foreign-type-declaration t "") "*)C_data_pointer(") + ; (expr (first subs) i) + ; (gen ")))") ) + + ((##core#inline_loc_update) + (bomb "ffi not supported")) + ;(let ([t (first params)]) + ; (gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(") + ; (expr (first subs) i) + ; (gen "))=" (foreign-argument-conversion t)) + ; (expr (second subs) i) + ; (gen "),C_SCHEME_UNDEFINED)") ) + + ((##core#switch) + (bomb "##core#switch not implemented")) + ;(gen #t "switch(") + ;(expr (first subs) i) + ;(gen "){") + ;(do ([j (first params) (sub1 j)] + ; [ps (cdr subs) (cddr ps)] ) + ; ((zero? j) + ; (gen #t "default:") + ; (expr (car ps) i) + ; (gen #\}) ) + ; (gen #t "case ") + ; (expr (car ps) i) + ; (gen #\:) + ; (expr (cadr ps) i) ) + + ((##core#cond) + (let* ((true-label (unique-label)) + (end-label (unique-label)) + (check-block (expr (first subs) bind-count)) + (true-block (expr (second subs) bind-count)) + (false-block (expr (third subs) bind-count)) + (ret (assembly-block-return-reg check-block)) + (true-ret (assembly-block-return-reg true-block)) + (false-ret (assembly-block-return-reg false-block))) + ;; We flatten out into one assembly-block, and make + ;; sure both true-ret and false-ret return the value in (temp 0) + (if (not ret) + (bomb "Check in if does not return a value")) + (make-assembly-block + (append (assembly-block-statements check-block) + `(("find_type" (I 0 #f) "\"Boolean\"") + ("typeof" (I 1 #f) ,ret) + ("ne" (I 0 #f) (I 1 #f) ,true-label) + ("if" ,ret ,true-label)) + ; The false code goes first + (cond ((and (eq? (car false-ret) 'temp) (eq? (cadr false-ret) 0)) + (assembly-block-statements false-block)) + ((eq? (car false-ret) 'temp) + (swap-regs 'temp 0 (cadr false-ret) (assembly-block-statements false-block))) + (else ;must be a (local) + `(("set" (temp 0 #f) ,false-ret)))) + `(("branch" ,end-label) + (,(string-append true-label ":"))) + (cond ((and (eq? (car true-ret) 'temp) (eq? (cadr true-ret) 0)) + (assembly-block-statements true-block)) + ((eq? (car true-ret) 'temp) + (swap-regs 'temp 0 (cadr true-ret) (assembly-block-statements true-block))) + (else ;must be a (local) + `(("set" (temp 0 #f) ,true-ret)))) + `((,(string-append end-label ": ")))) + '(temp 0)))) ;; TODO: Check if both true and false allow this... + + (else (bomb "bad form")) ) ) ) + + (values (expr node bind-start) (reverse single-binds) (reverse multi-binds) )) ) + + (define (header) + (define (pad0 n) + (if (< n 10) + (string-append "0" (number->string n)) + n) ) + (match (##sys#decode-seconds (current-seconds) #f) + [#(_ min hour mday mon year _ _ _ _) + (gen "# Generated from " source-file " by the Chicken compiler" #t + "# " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t + "# " (chicken-version #t) #t + "# command line: ") + (gen-list compiler-arguments) + (gen #t) + (cond [unit-name (gen "# unit: " unit-name)] + [else + (gen "# used units: ") + (gen-list used-units) ] ) + (unless unit-name + (gen #t "# default installation home: " (or default-installation-home "not specified") #t)) + ;(gen #t "*/" #t #t "#include \"" target-include-file "\"") + ;(when external-protos-first + ; (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) + ;(when (pair? foreign-declarations) + ; (gen #t) + ; (for-each (lambda (decl) (gen #t decl)) foreign-declarations) ) + ;(unless external-protos-first + ; (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) + ] ) ) + + (define (gen-init-code) + (let ((initialized_var (if unit-name + (string-append "Chicken::toplevel_" unit-name "_initialized") + "Chicken::toplevel_initialized"))) + (gen ".pcc_sub @LOAD __real_toplevel:" #t + "find_global I0," #\" initialized_var #\" #t + "if I0, __real_toplevel_trampoline" #t + "store_global " #\" initialized_var #\" ", 1" #t + "null P0" #t + "null P1" #t + "new P2, .FixedPMCArray #Closure" #t + "set P2, 1" #t + "set_addr I0, __real_toplevel_trampoline:" #t + "set P2[0], I0" #t + "branch toplevel" #t ;Possibly fasttailcall P2 + + "__real_toplevel_trampoline:" #t + "returncc" #t))) + + (define (trailer) + (gen #t "# end of file" #t) ) + + (define (literal-frame) + (make-assembly-block + (let ((n (length literals))) + (cons* + `("new" (temp 0 #f) ".FixedPMCArray") + `("set" (temp 0 #f) ,(number->string n)) + (append-map + (lambda (lit i) (gen-lit lit (list 'temp 0 i) 1)) + literals + (iota n 0)))) + '(temp 0 #f))) + + (define (bad-literal lit) + (bomb "type of literal not supported" lit) ) + + (define (gen-lit lit set-reg temp) + (cond ((or (fixnum? lit) (number? lit)) + ;(if (eq? 'flonum number-type)) + ;`(("new " (temp 1) ", .Float") + ; ("set " (temp 1) ", " ,(number->string lit)) + ; ("set " ,@frame ", " (temp 1))) + `(("set" ,set-reg ,(number->string lit)))) + ((block-variable-literal? lit)) + ((or (eq? lit (void))) + `(("null" (temp ,temp #f)) + ("set" ,set-reg (temp ,temp #f)))) + ((boolean? lit) + (if lit + `(("new" (temp ,temp #f) ".Boolean") + ("set" (temp ,temp #f) "1") + ("set" ,set-reg (temp ,temp #f))) + `(("new" (temp ,temp #f) ".Boolean") + ("set" ,set-reg (temp ,temp #f))))) + ((char? lit) + `(("set" ,set-reg ,(string-append "\"" lit "\"")))) + ((null? lit) + `(("new" (temp ,temp #f) ".SchemeEndOfList") + ("set" ,set-reg (temp ,temp #f)))) + ((string? lit) + `(("set" ,set-reg ,(c-ify-string lit)))) + ((pair? lit) + ;;; TODO: Possibly change representation of a pair from a FixedPMCArray + (append + `(("new" (temp ,temp #f) ".FixedPMCArray") + ("set" (temp ,temp #f) "2") + ("set" ,set-reg (temp ,temp #f))) + (gen-lit (car lit) `(temp ,temp 0) (+ temp 1)) + (gen-lit (cdr lit) `(temp ,temp 1) (+ temp 1)))) + ((vector? lit) (gen-vector-like-lit lit frame temp)) + ((symbol? lit) + (let* ([str (##sys#slot lit 1)] + [cstr (c-ify-string str)] + [len (##sys#size str)] + [nsi (namespace-lookup lit)] ) + (if nsi + `(("find_global" (temp ,temp #f) ,(c-ify-string nsi) cstr) + ("set" ,set-reg (temp ,temp #f))) + `(("find_global" (temp ,temp #f) ,cstr) + ("set" ,set-reg (temp ,temp #f)))))) + ((##sys#immediate? lit) (bad-literal lit)) + ;((##sys#bytevector? lit) + ; (if (##sys#permanent? lit) + ; (gen-string-like-lit to lit "C_pbytevector" #f) + ; (gen-string-like-lit to lit "C_bytevector" #t) ) ) + ((##sys#generic-structure? lit) (gen-vector-like-lit lit set-reg temp)) + (else (bad-literal lit)) ) ) + + (define (gen-vector-like-lit lit set-reg temp) + (let ([len (##sys#size lit)]) + (cons* + `("new" (temp ,temp #f) ".FixedPMCArray") + `("set" (temp ,temp #f) ,len) + `("set" ,set-reg (temp ,temp #f)) + (let loop ((j 0) (ret '())) + (if (= j len) + (reverse ret) + (loop (add1 j) + (append + (gen-lit (##sys#slot lit j) `(temp ,temp ,j) (+ temp 1)) + ret))))))) + + (define (procedures) + (for-each + (lambda (ll) + (let* ([argc (lambda-literal-argument-count ll)] + [id (lambda-literal-id ll)] + [rname (real-name id db)] + [customizable (lambda-literal-customizable ll)] + [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] ) + (when empty-closure (debugging 'o "dropping unused closure argument" id)) + (gen "# " rname #t) + (gen id #\: #t) + ;(if (toplevel_initialized) continue t1) + ;(gen C_toplevel_entry(C_text(topname))) + ;toplevel_initialized = 1 + + ;(set! func-using-in-overflow (> n num-args-in-regs)) + (display "exporting function ") (display id) (newline) + + ;; For every bind, calculate how many uses it has + (receive (single-bind-nums multi-bind-nums) (calc-bind-partition (lambda-literal-body ll) argc) + (map display (list " binds single: " single-bind-nums " multi: " multi-bind-nums)) (newline) + (set! func-check-bind-num + (lambda (num) + (let ((x (assoc num single-bind-nums))) + (if x + (values #t (cdr x)) + (values #f (cdr (assoc num multi-bind-nums))))))) + + (receive (call single-binds multi-binds) (expression (lambda-literal-body ll) argc ll) + (if (not (call? call)) + (bomb "lambda body did to return a call")) + + (let* ((num-locals + (fold + (lambda (bind x) + (let ((num (statement-bind-num bind))) + (if num + (max x (add1 num)) + x))) + argc + multi-binds)) + (lf (if (eq? 'toplevel id) + (literal-frame) + #f)) + (real-multi-binds + (if lf + (cons + (make-statement + (make-assembly-block + (append + (replace-reg (assembly-block-return-reg lf) (list 'lf 0 #f) (assembly-block-statements lf)) + '(("store_global" "chicken-literal-frame" (lf 0 #f)))) + #f) + #f) + multi-binds) + multi-binds))) + + ;(for-each dump-statement real-multi-binds) + ;(for-each dump-statement single-binds) + ;(dump-call call) + + (gen-assembly-list (allocate-registers num-locals single-binds real-multi-binds call)))))) + (gen #t) ) + ;(filter + ; (lambda (ll) + ; (let* ([partition (lambda-literal-partition ll)] + ; [in-partition (or (not file-partition) (= file-partition partition))]) + ; in-partition)) + ; lambdas) + lambdas)) + + (debugging 'p "code generation phase...") + (set! output out) + (header) + (gen-init-code) + ;(declarations) + ;(generate-external-variables external-variables) + ;(generate-foreign-stubs foreign-lambda-stubs db) + ;(generate-foreign-callback-stubs foreign-callback-stubs db) + (setup-quick-namespace-list) + (procedures) + (trailer) ) ) + + +;;; Create name that is safe for C comments: + +(define (cleanup s) + (let ([s2 #f] + [len (string-length s)] ) + (let loop ([i 0]) + (if (>= i len) + (or s2 s) + (let ([c (string-ref s i)]) + (if (or (char? c #\~) + (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) ) + (begin + (unless s2 (set! s2 (string-copy s))) + (string-set! s2 i #\~) ) + (when s2 (string-set! s2 i c)) ) + (loop (add1 i)) ) ) ) ) ) diff -rN -u old-chicken/parrot-inline.scm new-chicken/parrot-inline.scm --- old-chicken/parrot-inline.scm 1969-12-31 18:00:00.000000000 -0600 +++ new-chicken/parrot-inline.scm 2005-07-05 23:42:48.000000000 -0500 @@ -0,0 +1,51 @@ +; vim: expandtab + +(define-macro (inline name . body) + `(hash-table-set! inline-hash-table ,name + (lambda (expr subs) + ,@body))) + +(define-macro (inline-reduce initial final . body) + `(append + ,initial + (append-map + (lambda (x) + (let ((class (node-class x)) + (params (node-paramaters x))) + ,@body)) + subs) + ,final)) + +;(define-macro (inline-assembly-block-reduce initial final . body) +; `(inline-reduce +; ,initial +; ,final +; (let* ((n (expr x)) +; (ret (assembly-block-return-reg n)) +; (statements (assembly-block-statements n))) +; ,@body))) + +(inline "C_a_i_plus" + (if (not (= (length subs) 2)) + (bomb "C_a_i_plus not called with 2 arguments")) + (make-assmebly-block + (inline-reduce + + '(("set" (I 0 #f) "0")) + + '(("new" (temp 0 #f) ".Integer") + ("set" (temp 0 #f) (I 0 #f))) + + (if (and (eq? class '##core#immediate) + (eq? (first params) 'fix)) + `(("add" (I 0 #f) (I 0 #f) ,(number->string (second params)))) + + (let* ((n (expr x)) + (ret (assembly-block-return-reg n))) + (if (not ret) + (bomb "C_a_i_plus argument does not return a value")) + (append + (increment-regs 1 'I (assembly-block-statements n)) + `(("set" (I 1 #f) ,ret) + ("add" (I 0 #f) (I 0 #f) (I 1 #f))))))) + '(temp 0 #f))) diff -rN -u old-chicken/parrot-platform.scm new-chicken/parrot-platform.scm --- old-chicken/parrot-platform.scm 1969-12-31 18:00:00.000000000 -0600 +++ new-chicken/parrot-platform.scm 2005-07-05 23:54:55.000000000 -0500 @@ -0,0 +1,958 @@ +;;;; c-platform.scm - Platform specific parameters and definitions +; +; Copyright (c) 2000-2005, 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. +; +; Send bugs, suggestions and ideas to: +; +; felix@call-with-current-continuation.org +; +; Felix L. Winkelmann +; Unter den Gleichen 1 +; 37130 Gleichen +; Germany + + +(declare (unit platform)) + + +#{compiler + compiler-arguments process-command-line + default-standard-bindings default-extended-bindings side-effecting-standard-bindings + non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings + standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false + installation-home debugging + foreign-type-table-size dump-nodes + unit-name insert-timer-checks used-units inlining + foreign-declarations block-compilation analysis-database-size line-number-database-size + target-heap-size target-stack-size try-harder default-installation-home + default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size + current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables + rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants + broken-constant-nodes inline-substitutions-enabled + direct-call-ids foreign-type-table first-analysis + initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments + perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! + reorganize-recursive-bindings substitution-table simplify-named-call find-inlining-candidates perform-inlining! + perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda* + transform-direct-lambdas! decompose-lambda-list rewrite + debugging-chicken warnings-enabled bomb check-signature posq stringify symbolify flonum? build-lambda-list + string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant? + collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all + put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode + build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects? + simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list + pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables + topological-sort print-version print-usage initialize-analysis-database + copyright compiler-features default-declarations default-debugging-declarations units-used-by-default words-per-flonum + parameter-limit eq-inline-operator optimizable-rest-argument-operators + membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument + target-include-file default-profiling-declarations + default-optimization-passes internal-bindings + generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration + foreign-argument-conversion foreign-result-conversion} + + +(include "tweaks") + + +;;; Parameters: + +(define copyright "(c)2000-2005 Felix L. Winkelmann") + +(define default-optimization-passes 3) + +(define compiler-features + '(target-has-switch foreign-interface apply-simplifications) ) + +(define default-declarations + '((always-bound + ##sys#standard-input ##sys#standard-output ##sys#standard-error) + (bound-to-procedure + ##sys#for-each ##sys#map ##sys#print + ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values ##sys#match-error + ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot + ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set! + ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument + ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string + ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string + ##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 extras)) +(define words-per-flonum 4) +(define parameter-limit 1024) +(define small-parameter-limit 128) + +(define eq-inline-operator "C_eqp") +(define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref)) +(define 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) +(define target-include-file "chicken.h") + +(define valid-compiler-options + '(-help help version verbose explicit-use quiet no-trace no-warnings unsafe block assume-self-calls + check-syntax hygienic to-stdout no-usual-integrations case-insensitive emit-debug-info profile inline + fixnum-arithmetic disable-interrupts optimize-leaf-routines debug-calls syntax syntax-at-run-time + debug-loops strict strict-srfi-0 strict-reader lambda-lift run-time-macros tag-pointers accumulate-profile + disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw emit-external-prototypes-first + hygienic-at-run-time analyze-only strict-letrec dynamic ffi ffi-custom ffi-parse) ) + +(define valid-compiler-options-with-argument + '(debug output-file include-path heap-size stack-size unit uses keyword-style require-for-syntax inline-limit + prelude postlude prologue epilogue nursery extend feature no-feature compress-literals split-level + heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path split) ) + + +;;; Standard and extended bindings: + +(define 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! + null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port + write-char newline write display append symbol->string for-each map char? char->integer + integer->char eof-object? vector-length string-length string-ref string-set! vector-ref + vector-set! char=? char? char>=? char<=? gcd lcm reverse symbol? string->symbol + number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? + max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact + exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=? + char-ci? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? + char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string=? string<=? string-ci=? string-ci? string-ci<=? string-ci>=? + string-append string->list list->string vector? vector->list list->vector string read + read-char substring string-fill! vector-fill! make-string make-vector open-input-file + open-output-file call-with-input-file call-with-output-file close-input-port close-output-port + values call-with-values vector procedure? memq memv member assq assv assoc list-tail + list-ref abs char-ready? peek-char) ) + +(define default-extended-bindings + '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod + fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg + fp> fp< fp= fp>= fp<= atom? fxand fxnot fxior fxxor fxshr fxshl + arithmetic-shift void flush-output thread-specific thread-specific-set! + not-pair? null-list? print print* error cpu-time proper-list? call/cc + u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector + u32vector->byte-vector + s32vector->byte-vector byte-vector-length block-ref block-set! number-of-slots + f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set! + first second third fourth make-record-instance + u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length + f32vector-length f64vector-length + u8vector-ref s8vector-ref u16vector-ref s16vector-ref + u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set! + locative-ref locative-set! locative->object locative? + null-pointer? pointer->object) ) + +(define 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 + ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol + ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list + ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range? + ##sys#fudge ##sys#immediate? ##sys#direct-return + ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft + ##sys#bytevector? ##sys#make-vector + ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument + ##sys#foreign-block-argument ##sys#foreign-number-vector-argument + ##sys#foreign-string-argument ##sys#foreign-pointer-argument + ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number + ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double + ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) ) + +(define side-effecting-standard-bindings + '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display + peek-char char-ready? + read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file + open-output-file close-input-port close-output-port call-with-input-port call-with-output-port + call-with-values eval) ) + +(define non-foldable-standard-bindings + '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port) ) + +(define foldable-standard-bindings + (lset-difference + eq? default-standard-bindings + side-effecting-standard-bindings non-foldable-standard-bindings) ) + +(define non-foldable-extended-bindings + '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void + u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector + s32vector->byte-vector ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref + f32vector->byte-vector f64vector->byte-vector ##sys#byte ##sys#setbyte byte-vector-ref byte-vector-set! + u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length + f32vector-length f64vector-length ##sys#apply-values + u8vector-ref s8vector-ref u16vector-ref s16vector-ref + u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set! + ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) ) + +(define foldable-extended-bindings + (lset-difference + eq? default-extended-bindings non-foldable-extended-bindings) ) + +(define standard-bindings-that-never-return-false + '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer + integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min + quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin + cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string + string->list list->string vector->list list->vector read-char substring make-string make-vector + open-input-file open-output-file vector) ) + +(define side-effect-free-standard-bindings-that-never-return-false + (lset-difference + eq? standard-bindings-that-never-return-false + side-effecting-standard-bindings) ) + + +;;; Rewriting-definitions for this platform: + +(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f) + +(rewrite + '* 8 + (lambda (db classargs cont callargs) + ;; (*) -> 1 + ;; (* ) -> + ;; (* ...) -> (##core#inline "C_fixnum_times" (##core#inline "C_fixnum_times" ...)) [fixnum-mode] + ;; - Remove "1" from arguments. + ;; - Replace multiplications with 2 by shift left. [fixnum-mode] + (let ([callargs + (remove + (lambda (x) + (and (eq? 'quote (node-class x)) + (= 1 (first (node-parameters x))) ) ) + callargs) ] ) + (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))] + [(null? (cdr callargs)) + (make-node '##core#call '(#t) (list cont (first callargs))) ] + [(eq? number-type 'fixnum) + (make-node + '##core#call '(#t) + (list + cont + (fold-inner + (lambda (x y) + (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y)))) + (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1))) + (make-node '##core#inline '("C_fixnum_times") (list x y)) ) ) + callargs) ) ) ] + [else #f] ) ) ) ) + +(rewrite + '- 8 + (lambda (db classargs cont callargs) + ;; (- ) -> (##core#inline "C_fixnum_negate" ) [fixnum-mode] + ;; (- ) -> (##core#inline "C_u_fixnum_negate" ) [fixnum-mode + unsafe] + ;; (- ...) -> (##core#inline "C_fixnum_difference" (##core#inline "C_fixnum_difference" ...)) [fixnum-mode] + ;; (- ...) -> (##core#inline "C_u_fixnum_difference" (##core#inline "C_u_fixnum_difference" ...)) + ;; [fixnum-mode + unsafe] + ;; - Remove "0" from arguments, if more than 1. + (cond [(null? callargs) #f] + [(and (null? (cdr callargs)) (eq? number-type 'fixnum)) + (make-node + '##core#call '(#t) + (list cont + (make-node '##core#inline + (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate")) + callargs)) ) ] + [else + (let ([callargs + (cons (car callargs) + (remove + (lambda (x) + (and (eq? 'quote (node-class x)) + (zero? (first (node-parameters x))) ) ) + (cdr callargs) ) ) ] ) + (and (eq? number-type 'fixnum) + (>= (length callargs) 2) + (make-node + '##core#call '(#t) + (list + cont + (fold-inner + (lambda (x y) + (make-node '##core#inline + (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference")) + (list x y) ) ) + callargs) ) ) ) ) ] ) ) ) + +(rewrite + '/ 8 + (lambda (db classargs cont callargs) + ;; (/ ...) -> (##core#inline "C_fixnum_divide" (##core#inline "C_fixnum_divide" ...)) [fixnum-mode] + ;; - Remove "1" from arguments, if more than 1. + ;; - Replace divisions by 2 with shift right. [fixnum-mode] + (and (>= (length callargs) 2) + (let ([callargs + (cons (car callargs) + (remove + (lambda (x) + (and (eq? 'quote (node-class x)) + (= 1 (first (node-parameters x))) ) ) + (cdr callargs) ) ) ] ) + (and (eq? number-type 'fixnum) + (>= (length callargs) 2) + (make-node + '##core#call '(#t) + (list + cont + (fold-inner + (lambda (x y) + (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y)))) + (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1))) + (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) ) + callargs) ) ) ) ) ) ) ) + +(rewrite + 'quotient 8 + (lambda (db classargs cont callargs) + ;; (quotient 2) -> (##core#inline "C_fixnum_shift_right" 1) [fixnum-mode] + ;; (quotient ) -> (##core#inline "C_fixnum_divide" ) [fixnum-mode] + ;; (quotient ) -> ((##core#proc "C_quotient") ) + (and (= (length callargs) 2) + (if (eq? 'fixnum number-type) + (make-node + '##core#call '(#t) + (let ([arg2 (second callargs)]) + (list cont + (if (and (eq? 'quote (node-class arg2)) + (= 2 (first (node-parameters arg2))) ) + (make-node + '##core#inline '("C_fixnum_shift_right") + (list (first callargs) (qnode 1)) ) + (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) ) + (make-node + '##core#call '(#t) + (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) ) + +(rewrite + 'eqv? 8 + (lambda (db classargs cont callargs) + ;; (eqv? ) -> (quote #t) + ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum] + (and (= (length callargs) 2) + (let ([arg1 (first callargs)] + [arg2 (second callargs)] ) + (or (and (eq? '##core#variable (node-class arg1)) + (eq? '##core#variable (node-class arg2)) + (equal? (node-parameters arg1) (node-parameters arg2)) + (make-node '##core#call '(#t) (list cont (qnode #t))) ) + (and (or (and (eq? 'quote (node-class arg1)) + (not (flonum? (first (node-parameters arg1)))) ) + (and (eq? 'quote (node-class arg2)) + (not (flonum? (first (node-parameters arg2)))) ) ) + (make-node + '##core#call '(#t) + (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) ) ) + +(rewrite + 'equal? 8 + (lambda (db classargs cont callargs) + ;; (equal? ) -> (quote #t) + ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol] + ;; (equal? ...) -> (##core#inline "C_i_equalp" ...) + (and (= (length callargs) 2) + (let ([arg1 (first callargs)] + [arg2 (second callargs)] ) + (or (and (eq? '##core#variable (node-class arg1)) + (eq? '##core#variable (node-class arg2)) + (equal? (node-parameters arg1) (node-parameters arg2)) + (make-node '##core#call '(#t) (list cont (qnode #t))) ) + (and (or (and (eq? 'quote (node-class arg1)) + (let ([f (first (node-parameters arg1))]) + (or (immediate? f) (symbol? f)) ) ) + (and (eq? 'quote (node-class arg2)) + (let ([f (first (node-parameters arg2))]) + (or (immediate? f) (symbol? f)) ) ) ) + (make-node + '##core#call '(#t) + (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) + (make-node + '##core#call '(#t) + (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) ) + +(let () + (define (rewrite-apply db classargs cont callargs) + ;; (apply ... '( ...)) -> ( ... ' ...) + ;; (apply ...) -> ((##core#proc "C_apply") ...) + ;; (apply values ) -> ((##core#proc "C_apply_values") lst) + ;; (apply ##sys#values ) -> ((##core#proc "C_apply_values") lst) + (and (pair? callargs) + (let ([lastarg (last callargs)] + [proc (car callargs)] ) + (if (eq? 'quote (node-class lastarg)) + (make-node + '##core#call '(#f) + (cons* (first callargs) + cont + (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) ) + (or (and (eq? '##core#variable (node-class proc)) + (= 2 (length callargs)) + (let ([name (car (node-parameters proc))]) + (and (memq name '(values ##sys#values)) + (or (get db name 'standard-binding) + (get db name 'extended-binding) ) + (make-node + '##core#call '(#t) + (list (make-node '##core#proc '("C_apply_values" #t) '()) + cont + (cadr callargs) ) ) ) ) ) + (make-node + '##core#call '(#t) + (cons* (make-node '##core#proc '("C_apply" #t) '()) + cont callargs) ) ) ) ) ) ) + (rewrite 'apply 8 rewrite-apply) + (rewrite '##sys#apply 8 rewrite-apply) ) + +(let () + (define (rewrite-c..r op iop1 iop2 index) + (rewrite + op 8 + (lambda (db classargs cont callargs) + ;; ( ) -> (##core#inline "C_i_vector_ref"/"C_slot" (quote )) + ;; ( ) -> (##core#inline ) [safe] + ;; ( ) -> (##core#inline ) [unsafe] + (and (= (length callargs) 1) + (call-with-current-continuation + (lambda (return) + (let ([arg (first callargs)]) + (make-node + '##core#call '(#t) + (list + cont + (cond [(and (eq? '##core#variable (node-class arg)) + (eq? 'vector (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)] ) ) ) ) ) ) ) ) ) ) + + (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0) + (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1) + (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2) + (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr" 3) + (rewrite-c..r 'first "C_i_car" "C_u_i_car" 0) + (rewrite-c..r 'second "C_i_cadr" "C_u_i_cadr" 1) + (rewrite-c..r 'third "C_i_caddr" "C_u_i_caddr" 2) + (rewrite-c..r 'fourth "C_i_cadddr" "C_u_i_cadddr" 3) ) + +(let ([rvalues + (lambda (db classargs cont callargs) + ;; (values ) -> + (and (= (length callargs) 1) + (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] ) + (rewrite 'values 8 rvalues) + (rewrite '##sys#values 8 rvalues) ) + +(rewrite 'values 13 "C_values" #t) +(rewrite '##sys#values 13 "C_values" #t) +(rewrite 'call-with-values 13 "C_u_call_with_values" #f) +(rewrite 'call-with-values 13 "C_call_with_values" #t) +(rewrite '##sys#call-with-values 13 "C_u_call_with_values" #f) +(rewrite '##sys#call-with-values 13 "C_call_with_values" #t) +(rewrite 'cpu-time 13 "C_cpu_time" #t) +(rewrite 'locative-ref 13 "C_locative_ref" #t) +(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t) + +(rewrite 'caar 2 1 "C_u_i_caar" #f #f) +(rewrite 'cdar 2 1 "C_u_i_cdar" #f #f) +(rewrite 'cddr 2 1 "C_u_i_cddr" #f #f) +(rewrite 'caaar 2 1 "C_u_i_caaar" #f #f) +(rewrite 'cadar 2 1 "C_u_i_cadar" #f #f) +(rewrite 'caddr 2 1 "C_u_i_caddr" #f #f) +(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f) +(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f) +(rewrite 'cddar 2 1 "C_u_i_cddar" #f #f) +(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f) +(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f) +(rewrite 'caadar 2 1 "C_u_i_caadar" #f #f) +(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f) +(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f) +(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f) +(rewrite 'caddar 2 1 "C_u_i_caddar" #f #f) +(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f) +(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f) +(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f) +(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f) +(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f) +(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f) +(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f) +(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f) +(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f) + +(rewrite 'cddr 2 1 "C_i_cddr" #t #f) +(rewrite 'cdddr 2 1 "C_i_cdddr" #t #f) +(rewrite 'cddddr 2 1 "C_i_cddddr" #t #f) + +(rewrite 'cdr 7 1 "C_slot" 1 #f) +(rewrite 'cdr 2 1 "C_i_cdr" #t #f) + +(rewrite 'eq? 1 2 "C_eqp") +(rewrite 'eqv? 1 2 "C_i_eqvp") + +(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot") +(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref") +(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp") +(rewrite 'length 2 1 "C_i_length" #t "C_block_size") +(rewrite 'not 2 1 "C_i_not" #t #f) +(rewrite 'char? 2 1 "C_charp" #t #f) +(rewrite 'string? 2 1 "C_i_stringp" #t #f) +(rewrite 'locative? 2 1 "C_i_locativep" #t #f) +(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f) +(rewrite 'vector? 2 1 "C_i_vectorp" #t #f) +(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp") +(rewrite 'atom? 2 1 "C_i_atomp" #t #f) +(rewrite 'procedure? 2 1 "C_i_closurep" #t #f) +(rewrite 'port? 2 1 "C_i_portp" #t #f) +(rewrite 'boolean? 2 1 "C_booleanp" #t #f) +(rewrite 'number? 2 1 "C_i_numberp" #t #f) +(rewrite 'complex? 2 1 "C_i_numberp" #t #f) +(rewrite 'rational? 2 1 "C_i_numberp" #t #f) +(rewrite 'real? 2 1 "C_i_numberp" #t #f) +(rewrite 'integer? 2 1 "C_i_integerp" #t #f) +(rewrite 'fixnum? 2 1 "C_fixnump" #t #f) +(rewrite '##sys#pointer? 2 1 "C_pointerp" #t #f) +(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f) +(rewrite 'exact? 2 1 "C_fixnump" #f #f) +(rewrite 'exact? 2 1 "C_i_exactp" #t #f) +(rewrite 'exact? 2 1 "C_u_i_exactp" #f #f) +(rewrite 'inexact? 2 1 "C_nfixnump" #f #f) +(rewrite 'inexact? 2 1 "C_i_inexactp" #t #f) +(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f) +(rewrite 'list? 2 1 "C_i_listp" #t #f) +(rewrite 'proper-list? 2 1 "C_i_listp" #t #f) +(rewrite 'eof-object? 2 1 "C_eofp" #t #f) +(rewrite 'string-ref 2 2 "C_subchar" #f #f) +(rewrite 'string-ref 2 2 "C_i_string_ref" #t #f) +(rewrite 'string-set! 2 3 "C_setsubchar" #f #f) +(rewrite 'string-set! 2 3 "C_i_string_set" #t #f) +(rewrite 'vector-ref 2 2 "C_slot" #f #f) +(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f) +(rewrite 'char=? 2 2 "C_eqp" #t #f) +(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f) +(rewrite 'char=? 2 2 "C_fixnum_greater_or_equal_p" #t #f) +(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f) +(rewrite '##sys#slot 2 2 "C_slot" #t #f) ; consider as safe, the primitive is unsafe anyway. +(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ; must be safe for pattern matcher +(rewrite '##sys#size 2 1 "C_block_size" #t #f) +(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f) +(rewrite 'fx* 2 2 "C_fixnum_times" #t #f) +(rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f) +(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f) +(rewrite 'fx= 2 2 "C_eqp" #t #f) +(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f) +(rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f) +(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f) +(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f) +(rewrite 'fp= 2 2 "C_flonum_equalp" #t #f) +(rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f) +(rewrite 'fp< 2 2 "C_flonum_lessp" #t #f) +(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f) +(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f) +(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f) +(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f) +(rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f) +(rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f) +(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f) +(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f) +(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f) +(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f) +(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f) +(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f) +(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f) +(rewrite 'list-tail 2 2 "C_i_list_tail" #t #f) +(rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f) +(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f) +(rewrite 'block-ref 2 2 "C_slot" #f #f) ; ok to be unsafe, lolevel is anyway +(rewrite 'number-of-slots 2 1 "C_block_size" #f #f) + +(rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq") +(rewrite 'assv 2 2 "C_i_assv" #t #f) +(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq") +(rewrite 'memv 2 2 "C_i_memv" #t #f) +(rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq") +(rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq") +(rewrite 'assoc 2 2 "C_i_assoc" #t #f) +(rewrite 'member 2 2 "C_i_member" #t #f) + +(rewrite 'set-car! 4 '##sys#setslot 0) +(rewrite 'set-cdr! 4 '##sys#setslot 1) +(rewrite 'set-car! 17 2 "C_i_set_car" "C_u_i_set_car") +(rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr") + +(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs") +(rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum) + +(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum) +(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum) +(rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_a_i_bitwise_ior" words-per-flonum) + +(rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not") + +(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum) +(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum) +(rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum) +(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum) +(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum) + +(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum) +(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum) +(rewrite 'cos 16 1 "C_a_i_cos" #t words-per-flonum) +(rewrite 'tan 16 1 "C_a_i_tan" #t words-per-flonum) +(rewrite 'log 16 1 "C_a_i_log" #t words-per-flonum) +(rewrite 'asin 16 1 "C_a_i_asin" #t words-per-flonum) +(rewrite 'acos 16 1 "C_a_i_acos" #t words-per-flonum) +(rewrite 'atan 16 1 "C_a_i_atan" #t words-per-flonum) +(rewrite 'sqrt 16 1 "C_a_i_sqrt" #t words-per-flonum) +(rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum) + +(rewrite 'zero? 5 "C_eqp" 0 'fixnum) +(rewrite 'zero? 2 1 "C_i_zerop" #t #f) +(rewrite 'zero? 2 1 "C_u_i_zerop" #f #f) +(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum) +(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum) +(rewrite 'positive? 2 1 "C_i_positivep" #t #f) +(rewrite 'positive? 2 1 "C_u_i_positivep" #f #f) +(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum) +(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum) +(rewrite 'negative? 2 1 "C_i_negativep" #t #f) +(rewrite 'negative? 2 1 "C_u_i_negativep" #f #f) + +(rewrite 'vector-length 6 "C_fix" "C_header_size" #f) +(rewrite 'string-length 6 "C_fix" "C_header_size" #f) +(rewrite 'char->integer 6 "C_fix" "C_character_code" #t) +(rewrite 'integer->char 6 "C_make_character" "C_unfix" #t) + +(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f) +(rewrite 'string-length 2 1 "C_i_string_length" #t #f) +(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f) + +(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f) +(rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f) +(rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f) +(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f) +(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f) +(rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f) +(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f) +(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f) +(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f) +(rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f) +(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f) +(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f) +(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f) +(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f) +(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f) +(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f) +(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f) +(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f) +(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f) +(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f) + +(rewrite '= 9 "C_eqp" "C_i_equalp" #t #t) +(rewrite '> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f) +(rewrite '< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f) +(rewrite '>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f) +(rewrite '<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f) + +(rewrite 'for-each 11 2 '##sys#for-each #t) +(rewrite 'map 11 2 '##sys#map #t) +(rewrite 'block-set! 11 3 '##sys#setslot #t) +(rewrite '##sys#block-set! 11 3 '##sys#setslot #f) +(rewrite 'make-record-instance 11 #f '##sys#make-structure #f) +(rewrite 'substring 11 3 '##sys#substring #f) +(rewrite 'string-append 11 2 '##sys#string-append #f) + +(rewrite 'vector-set! 11 3 '##sys#setslot #f) +(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f) + +(rewrite 'gcd 12 '##sys#gcd #t 2) +(rewrite 'lcm 12 '##sys#lcm #t 2) +(rewrite 'identity 12 #f #t 1) + +(rewrite 'gcd 18 0) +(rewrite 'lcm 18 1) +(rewrite 'list 18 '()) + +(rewrite 'argv 13 "C_get_argv" #t) + +(rewrite '* 16 2 "C_a_i_times" #t 4) ; words-per-flonum +(rewrite '+ 16 2 "C_a_i_plus" #t 4) ; words-per-flonum +(rewrite '- 16 2 "C_a_i_minus" #t 4) ; words-per-flonum +(rewrite '/ 16 2 "C_a_i_divide" #t 4) ; words-per-flonum +(rewrite '= 17 2 "C_i_nequalp") +(rewrite '> 17 2 "C_i_greaterp") +(rewrite '< 17 2 "C_i_lessp") +(rewrite '>= 17 2 "C_i_greater_or_equalp") +(rewrite '<= 17 2 "C_i_less_or_equalp") + +(rewrite '* 13 "C_times" #t) +(rewrite '- 13 "C_minus" #t) +(rewrite '+ 13 "C_plus" #t) +(rewrite '/ 13 "C_divide" #t) +(rewrite '= 13 "C_nequalp" #t) +(rewrite '> 13 "C_greaterp" #t) +(rewrite '< 13 "C_lessp" #t) +(rewrite '>= 13 "C_greater_or_equal_p" #t) +(rewrite '<= 13 "C_less_or_equal_p" #t) + +(rewrite 'exact->inexact 13 "C_exact_to_inexact" #t) +(rewrite 'string->number 13 "C_string_to_number" #t) +(rewrite 'number->string 13 "C_number_to_string" #t) +(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t) +(rewrite '##sys#floor 13 "C_flonum_floor" #t) +(rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t) +(rewrite '##sys#truncate 13 "C_flonum_truncate" #t) +(rewrite '##sys#round 13 "C_flonum_round" #t) +(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t) +(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t) +(rewrite '##sys#call-host 13 "C_call_host" #t) +(rewrite '##sys#host-data 13 "C_host_data" #t) +(rewrite '##sys#set-host-data! 13 "C_set_host_data" #t) +(rewrite '##sys#context-switch 13 "C_context_switch" #t) +(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t) +(rewrite '##sys#make-symbol 13 "C_make_symbol" #t) + +(rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp") +(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp") +(rewrite 'add1 14 'fixnum 1 "C_fixnum_increase" "C_u_fixnum_increase") +(rewrite 'sub1 14 'fixnum 1 "C_fixnum_decrease" "C_u_fixnum_decrease") +(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo") + +(rewrite 'even? 2 1 "C_i_evenp" #t #f) +(rewrite 'even? 2 1 "C_u_i_evenp" #f #f) +(rewrite 'odd? 2 1 "C_i_oddp" #t #f) +(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f) + +(rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f) +(rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f) +(rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f) +(rewrite 'round 15 'flonum 'fixnum '##sys#round #f) + +(rewrite 'cons 16 2 "C_a_i_cons" #t 3) +(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3) +(rewrite 'list 16 #f "C_a_i_list" #t '(3)) +(rewrite '##sys#list 16 #f "C_a_i_list" #t '(3)) +(rewrite 'vector 16 #f "C_a_i_vector" #t #t) +(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t) +(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t) + +(rewrite + '##sys#setslot 8 + (lambda (db classargs cont callargs) + ;; (##sys#setslot ) -> (##core#inline "C_i_set_i_slot" ) + ;; (##sys#setslot ) -> (##core#inline "C_i_setslot" ) + (and (= (length callargs) 3) + (make-node + '##core#call '(#t) + (list cont + (make-node + '##core#inline + (let ([val (third callargs)]) + (if (and (eq? 'quote (node-class val)) + (immediate? (first (node-parameters val))) ) + '("C_i_set_i_slot") + '("C_i_setslot") ) ) + callargs) ) ) ) ) ) + +(rewrite 'fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus") +(rewrite 'fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference") +(rewrite 'fxshl 17 2 "C_fixnum_shift_left") +(rewrite 'fxshr 17 2 "C_fixnum_shift_right") +(rewrite 'fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate") +(rewrite 'fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor") +(rewrite 'fxand 17 2 "C_fixnum_and" "C_u_fixnum_and") +(rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or") + +(rewrite + 'arithmetic-shift 8 + (lambda (db classargs cont callargs) + ;; (arithmetic-shift <-int>) -> (##core#inline "C_fixnum_shift_right" -) + ;; (arithmetic-shift <+int>) -> (##core#inline "C_fixnum_shift_left" ) + ;; _ -> (##core#inline "C_a_i_arithmetic_shift" ) + ;; not in fixnum-mode: _ -> (##core#inline_allocate ("C_a_i_arithmetic_shift" words-per-flonum) ) + (and (= 2 (length callargs)) + (let ([val (second callargs)]) + (make-node + '##core#call '(#t) + (list cont + (or (and-let* ([(eq? 'quote (node-class val))] + [(eq? number-type 'fixnum)] + [n (first (node-parameters val))] + [(fixnum? n)] ) + (if (negative? n) + (make-node + '##core#inline '("C_fixnum_shift_right") + (list (first callargs) (qnode (- n))) ) + (make-node + '##core#inline '("C_fixnum_shift_left") + (list (first callargs) val) ) ) ) + (if (eq? number-type 'fixnum) + (make-node '##core#inline '("C_i_fixnum_arithmetic_shift") callargs) + (make-node '##core#inline_allocate (list "C_a_i_arithmetic_shift" words-per-flonum) + callargs) ) ) ) ) ) ) ) ) + +(rewrite '##sys#byte 17 2 "C_subbyte") +(rewrite '##sys#setbyte 17 3 "C_setbyte") +(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum") +(rewrite '##sys#peek-byte 17 2 "C_peek_byte") +(rewrite 'pointer->object 17 2 "C_pointer_to_object") +(rewrite '##sys#setislot 17 3 "C_i_set_i_slot") +(rewrite '##sys#poke-integer 17 3 "C_poke_integer") +(rewrite '##sys#poke-double 17 3 "C_poke_double") +(rewrite '##sys#double->number 17 1 "C_double_to_number") +(rewrite 'string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p") +(rewrite 'string-ci=? 17 2 "C_i_string_ci_equal_p") +(rewrite '##sys#fudge 17 1 "C_fudge") +(rewrite '##sys#fits-in-int? 17 1 "C_fits_in_int_p") +(rewrite '##sys#fits-in-unsigned-int? 17 1 "C_fits_in_unsigned_int_p") +(rewrite '##sys#flonum-in-fixnum-range? 17 1 "C_flonum_in_fixnum_range_p") +(rewrite '##sys#permanent? 17 1 "C_permanentp") +(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp") +(rewrite 'null-pointer? 17 1 "C_i_null_pointerp" "C_null_pointerp") +(rewrite '##sys#immediate? 17 1 "C_immp") +(rewrite 'locative->object 17 1 "C_i_locative_to_object") +(rewrite 'locative-set! 17 2 "C_i_locative_set") +(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp") +(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp") +(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp") +(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp") +(rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp") +(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp") +(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp") +(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp") +(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp") +(rewrite '##sys#direct-return 17 2 "C_direct_return") + +(rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f) +(rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f) +(rewrite 'byte-vector-length 2 1 "C_block_size" #f #f) + +(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f) +(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f) +(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f) +(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f) + +(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f) +(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f) +(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f) +(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f) +(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f) +(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f) + +(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f) +(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f) +(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f) +(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f) +(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f) +(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f) +(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f) +(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f) + +(rewrite 'not-pair? 17 1 "C_i_not_pair_p") +(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp") + +(rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f) +(rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f) + +(let () + (define (rewrite-make-vector db classargs cont callargs) + ;; (make-vector ' []) -> (let (( )) (##core#inline_allocate ("C_a_i_vector" +1) ' )) + ;; - should be less or equal to 32. + (let ([argc (length callargs)]) + (and (pair? callargs) + (let ([n (first callargs)]) + (and (eq? 'quote (node-class n)) + (let ([tmp (gensym)] + [c (first (node-parameters n))] ) + (and (fixnum? c) + (<= c 32) + (let ([val (if (pair? (cdr callargs)) + (second callargs) + (make-node '##core#undefined '() '()) ) ] ) + (make-node + 'let + (list tmp) + (list val + (make-node + '##core#call '(#t) + (list cont + (make-node + '##core#inline_allocate + (list "C_a_i_vector" (add1 c)) + (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) + (rewrite 'make-vector 8 rewrite-make-vector) + (rewrite '##sys#make-vector 8 rewrite-make-vector) ) + +(rewrite 'thread-specific 7 1 "C_slot" 10 #f) +(rewrite 'thread-specific-set! 20 2 "C_i_setslot" 10 #f) + +(let () + (define (rewrite-call/cc db classargs cont callargs) + (and (= 1 (length 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 + 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)) + (begin + (debugging 'x "removing unused `call/cc'") + (make-node + '##core#call '(#t) + (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) ) ) + (rewrite 'call-with-current-continuation 8 rewrite-call/cc) + (rewrite 'call/cc 8 rewrite-call/cc) ) diff -rN -u old-chicken/parrot-register-alloc.scm new-chicken/parrot-register-alloc.scm --- old-chicken/parrot-register-alloc.scm 1969-12-31 18:00:00.000000000 -0600 +++ new-chicken/parrot-register-alloc.scm 2005-07-07 01:49:03.000000000 -0500 @@ -0,0 +1,516 @@ +;;;; The following functions are used during register-allocation +;; vim: expandtab + +(declare (unit parrot-register-alloc)) + +#{compiler gen topological-sort bomb} + +(define (replace-inline pred lst) + (let loop ((lst lst)) + (if (null? lst) + '() + (let* ((x (car lst)) + (ret (pred x))) + (if ret + (append ret (loop (cdr lst))) + (cons x (loop (cdr lst)))))))) + +;; Count the number of registers used in a block +(define (max-reg-num type code) + (fold + (lambda (statement n) + (max n + (fold + (lambda (entry n2) + (if (and (list? entry) (eq? (car entry) type)) + (max n2 (cadr entry)) + n2)) + -1 + statement))) + -1 + code)) + +;; Return a list of all locals used in a block +(define (find-locals code num-output-args) + (fold + (lambda (statement rest) + (lset-union = + rest + (fold + (lambda (entry rest) + (if (and (list? entry) (eq? (car entry) 'local) (< (cadr entry) num-output-args)) + (lset-adjoin = rest (cadr entry)) + rest)) + '() + statement))) + '() + code)) + +;; Expand out (bind num index) to add the statements in bind to the assembly block +(define (expand-binds block binds-vec) + (let* ((ret (assembly-block-return-reg block)) + (num-saves (max-reg-num 'save (assembly-block-statements block))) + + ;; First expand all binds inside (assembly-block-statements block) + (statements + (replace-inline + (lambda (statement) + (let ((reg (find (lambda (x) + (if (and (list? x) (eq? (first x) 'bind)) + x + #f)) + statement))) + (if reg + (let* ((bind (vector-ref binds-vec (second reg))) + (bind-block (and bind (statement-block bind))) + (expanded-block (and bind (expand-binds bind-block binds-vec))) + (bind-ret (and bind-block (assembly-block-return-reg bind-block))) + (bind-real-ret (if (and bind-ret (> num-saves -1) (eq? (car bind-ret) 'save)) + (list 'save (+ (second bind-ret) num-saves 1) (third bind-ret)) + bind-ret))) + (if (not bind) + (bomb "Bind can not be found")) + (if (not bind-ret) + (bomb "Bind block does not return a value")) + (append + (if (> num-saves -1) + (increment-regs (add1 num-saves) 'save (assembly-block-statements expanded-block)) + (assembly-block-statements expanded-block)) + (replace-reg reg bind-real-ret (list statement)))) + #f))) + (assembly-block-statements block)))) + + ;; Then expand (assembly-block-return-reg block) + (if (and ret (eq? (car ret) 'bind)) + (let* ((bind (vector-ref binds-vec (second ret))) + (bind-block (and bind (statement-block bind))) + (expanded-block (and bind (expand-binds bind-block binds-vec)))) + (make-assembly-block + (append + statements + (assembly-block-statements expanded-block)) + (assembly-block-return-reg expanded-block))) + + ;; Return register not a bind + (make-assembly-block + statements + ret)))) + + +;; Remove the (save) by converting to (temp) +(define (remove-save block) + (let* ((num-save (max-reg-num 'save (assembly-block-statements block))) + (ret (assembly-block-return-reg block)) + (real-ret (if (and ret (eq? (car ret) 'save)) + (list 'temp (second ret) (third ret)) + ret))) + (make-assembly-block + (let loop ((i num-save) + (lst (increment-regs (add1 num-save) 'temp (assembly-block-statements block)))) + (if (= i -1) + lst + (loop (- i 1) + (replace-reg (list 'save i #f) (list 'temp i #f) lst)))) + real-ret))) + +(define (transform-blocks binds call func) + (map + (lambda (bind) (statement-block-set! bind (func (statement-block bind)))) + binds) + ;(call-true-function-set! call (func (call-true-function call))) + (call-true-args-set! call (map func (call-true-args call))) + (when (call-if-block call) + (call-if-block-set! call (func (call-if-block call))) + ;(call-false-function-set! call (func (call-false-function call))) + (call-false-args-set! call (map func (call-false-args call))))) + +;; Calculate the order we will create the output arguments. +;; We first detect cycles of dependencies, then sort the dag topologically +;; We then remove one node from the cycle, and recursivly sort the rest of the cycle +(define (sort-dg dg) + ;; Calculate all the cycles and the dag with the cycles removed + ;; This algorithm is N^2, since we want each cycle to be as large as possible + ;; It might be possible to do faster, but this algorithm works... + (receive (cycles dag) + (let loop ((nodes dg) (cycles '()) (dag '())) + (if (null? nodes) + (values cycles dag) + ;; This function returns all the nodes in a cycle + (letrec ((walk + (lambda (node seen) + (if (or (not node) (null? node) (member (car node) seen)) + '() + (fold + (lambda (n set) + (lset-union = set + (if (= n (caar nodes)) ;; If found a cycle? + (cons (car node) seen) + (walk (find (lambda (x) (= (car x) n)) (cdr nodes)) + (cons (car node) seen))))) + '() + (cdr node)))))) + + ;; Calculate if there is a cycle involving from (car nodes) + ;; The cons below should really be lset-adjoin, but (caar nodes) can only be in cycles if the node points to itself + (let ((cycle (cons (caar nodes) (walk (car nodes) '())))) + (if (null? (cdr cycle)) + ;; If no cycle, add (car nodes) to the dag and continue + (loop (cdr nodes) cycles (cons (car nodes) dag)) + ;; If there is a cycle, replace the entire cycle with a node new-sym + ;; And then add (new-sym cycle-nodes) to cycles + (let ((new-sym (gensym))) + (receive (cnodes other-nodes) (partition + (lambda (x) (member (car x) cycle)) + nodes) + (loop + ;; Need to replace any edge in other-nodes that connects to a node in the cycle with new-sym + (map (lambda (node) + (cons (car node) ;; (car node) is the actual node + (let loop ((lst (cdr node)) + (ret '()) + (added #f)) + (if (null? lst) + ret + (if (member (car lst) cycle) + (if added + (loop (cdr lst) ret #t) + (loop (cdr lst) (cons new-sym ret) #t)) + (loop (cdr lst) (cons (car lst) ret) added)))))) + other-nodes) + + (cons + (cons new-sym cnodes) + cycles) + + (cons + ;; Create the new-sym node. + ;; It needs to connect to all nodes cnodes touches that are not in cycle + (cons new-sym + (fold + (lambda (node set) + (lset-union = set + (fold + (lambda (n set) + (if (not (member n cycle)) + (lset-adjoin = n set) + set)) + '() + (cdr node)))) + '() + cnodes)) + dag))))))))) + + (let ((tsort (topological-sort dag eq?)) + ;; Deal with the cycles by removing one element and recursivly sorting the rest + (sorted-cycles + (map + (lambda (cycle) + ;; cycle sym name node that was removed rest of the elements in the cycle + (cons (car cycle) (cons (caadr cycle) (sort-dg (cddr cycle))))) + cycles))) + (if (null? cycles) + tsort + (let loop ((lst tsort) (ret '())) + (if (null? lst) + (reverse ret) + (let ((x (car lst))) + (if (symbol? x) + (loop (cdr lst) + ;; Add the entire list of nodes in the cycle as one element in the returned list + (cons (cdr (assq x sorted-cycles)) ret)) + (loop (cdr lst) + (cons x ret)))))))))) + +;; This is the version that does register spilling... Doesn't currently work +;(define (allocate-temps code used) + +; (define (expand-temps code temps) +; (fold +; (lambda (i t code) +; (replace-reg (list 'temp i #f) (string-append "P" (number->string t)) code)) +; code +; (iota 0 (length temps)) +; temps)) + +; (let ((temps (lset-difference = (iota 1 15) used)) +; (num-free (length temps)) +; (used-temps (count-regs 'temp code))) +; (if (<= used-temps num-free) +; (expand-temps code temps) +; ;; Need to do register spilling... +; (let* ((used-locals (find-locals code)) +; (possible-save (lset-difference = (iota 1 15) temps used-locals)) +; (num-possible-save (length possible-save))) +; (if (> (+ num-free num-possible-save) used-temps) +; (bomb "too many registers used at once")) +; (receive (temps prefix-code postfix-code) +; (let loop ((i (- used-temps num-free)) +; (lst possible-save)) +; (if (= i 0) +; (values temps '() '()) +; (receive (temps pre post) (loop (- i 1) (cdr lst)) +; (let ((t (car lst))) +; (values +; (cons t temps) +; (cons `("save" ,(string-append "P" (number->string t))) pre) +; (cons `("restore" ,(string-append "P" (number->string t))) post)))))) +; (append +; prefix-code +; (expand-temps code temps) +; postfix-code)))))) + +(define (expand-real-registers code) + (map + (lambda (statement) + (map + (lambda (x) + (if (list? x) + (let ((type (car x)) + (num (second x)) + (index (third x))) + (case type + ((local) + (if index + (string-append "P" (number->string (add1 num)) "[" (number->string index) "]") + (string-append "P" (number->string (add1 num))))) + ((lf) + (if (not (= num 0)) + (bomb "Literal frame non-zero register access")) + (if index + (string-append "P0[" (number->string index) "]") + "P0")) + ((I S F) + (if index + (bomb "Unable to index non-PMC register")) + (string-append (symbol->string type) (number->string num))) + (else + (bomb "Illegal register type" (symbol->string type))))) + x)) + statement)) + code)) + +(define (allocate-temps code used) + (let* ((max-used-num (apply max (cons -1 used))) + (unused (if (null? used) + '() + (lset-difference = (iota (+ max-used-num 1)) used))) + (num-unused (length unused)) + (num-used-temps (+ (max-reg-num 'temp code) 1)) + (temps + (if (<= num-used-temps num-unused) + unused + (append unused (iota (- num-used-temps num-unused) (+ max-used-num 1)))))) + (fold-right + (lambda (i t code) + (replace-reg (list 'temp i #f) (list 'local t #f) code)) + code + (iota num-used-temps) + temps))) + + +;; Return the list of code that correctly manages the flow of data from input registers to output registers, +;; so that the results are calculated in the correct order. Also expand out all temp registers. +(define (allocate-call-regs blocks num-locals) + + ;; Build up the node list. We special case nodes that point to themselves. + (receive (nodes self-loops) (let loop ((lst blocks) (count 0)) + (if (null? lst) + (values '() '()) + (receive (n s) (loop (cdr lst) (add1 count)) + (let ((locals (find-locals (assembly-block-statements (car lst)) (length blocks)))) + (if (member count locals) + (values + (cons (cons count (delete count locals =)) n) + (cons count s)) + (values + (cons (cons count locals) n) + s)))))) + (map display (list " nodes: " nodes " self-loops: " self-loops)) (newline) + (let* ( + ;; First transform any overflow argumnets into one block + ;(real-blocks + ; (if (> (length blocks) num-args-in-regs) + ; (append + ; (take blocks num-args-in-regs) + ; (let ((overflow (drop blocks num-args-in-regs))) + ; (make-assembly-block + ; (cons '("new" (temp 1 #f) ".FixedPMCArray # Overflow args") + ; (cons `("set" (temp 1 #f) ,(length overflow)) + ; (append-map + ; (lambda (n count) + ; (let* ((ret (assembly-block-return-reg n)) + ; (inc-ret (if (and ret (eq? (car ret) 'temp)) + ; (list 'temp (add1 (cadr ret)) (third ret)) + ; ret))) + ; (if (not ret) + ; (bomb "Output argument does not return a value")) + ; (if (reg-replace-array-set? ret (assembly-block-statements n)) + ; (replace-reg ret + ; `(temp 1 ,count) + ; (increment-regs 1 'temp (assembly-block-statements n))) + ; (append + ; (increment-regs 1 'temp (assembly-block-statements n)) + ; `(("set" (temp 1 ,count) ,ret)))))) + ; overflow + ; (iota (length overflow) 0)))) + ; '(temp 1 #f)))) + ; blocks)) + + (call-arg-vector (list->vector blocks)) + + (order (sort-dg nodes)) + + ;; Calculate which registers are used during the calculation of each argument + ;; TODO: This doesn't work yet... instead we just assume all locals are used + ;(order-flat (let loop ((lst order)) + ; (if (null? lst) + ; '() + ; (let ((x (car lst))) + ; (if (list? x) ;; If element is a cycle + ; (append (loop (cdr x)) (loop (cdr lst))) + ; (cons x (loop (cdr lst)))))))) + ;(used-regs + ; (letrec ((loop + ; (lambda (lst seen) + ; (if (null? lst) + ; (values '() '()) + ; (let* ((node (car lst)) + ; (node-num (car node)) + ; (node-used (cdr node))) + ; (receive (ret regs) (loop (cdr lst) (cons node-num seen)) + ; (let ((accessed (lset-union = node-used regs))) + ; (values + ; (cons (cons node-num (lset-union = accessed seen)) ret) + ; accessed)))))))) + ; (receive (ret x) (loop order-flat '()) + ; ret))) + ) + + (display " order: ") (display order) (newline) + ;; Setting up the arguments for the call + (letrec ((walk + (lambda (lst) + (fold-right (lambda (x rest) + (if (list? x) ;; If the element is a cycle + + ;; Deal with the cycle by first computing the node, and either saving it on the stack + ;; or sticking it into a temporary register (if there are enough available) + (let* ((node (car x)) + (sub-nodes (cdr x)) + (block (vector-ref call-arg-vector node)) + (ret (assembly-block-return-reg block))) + + ;; generate node on the stack + ;; TODO: use a temporary registrer instead + (append + (allocate-temps + (append + (assembly-block-statements block) + `(("save" ,ret))) + ;(cdr (assoc node used-regs)) + (iota num-locals) + ) + + (walk sub-nodes) + + `(("restore" (output-reg node))) + + rest)) + + + ;; If the node is not a cycle, just calculate it directly into the output register + (let* ((block (vector-ref call-arg-vector x)) + (ret (assembly-block-return-reg block)) + (statements (assembly-block-statements block))) + (append + (allocate-temps + (if (and (eq? (car ret) 'temp) (not (member x self-loops))) + (replace-reg ret `(local ,x #f) statements) + (append + statements + `(("set" (local ,x #f) ,ret)))) + ;(cdr (assoc x used-regs)) + (iota num-locals) + ) + rest)))) + '() + lst)))) + (walk order))))) + +;; Expands out registers to properly manage the flow of data between +;; the input registers and the output registers. +;; It returns the list of assembly code that can be exported, or further optimized +(define (allocate-registers num-locals single-binds multi-binds call) + + (transform-blocks multi-binds call + (let ((vec (list->vector single-binds))) + (lambda (x) (expand-binds x vec)))) + + (transform-blocks multi-binds call remove-save) + + ;(gen "### START OF TRANSFORMED CODE after remove save" #t) + ;(for-each dump-statement multi-binds) + ;(dump-call call) + ;(gen "### END OF TRANSFORMED CODE" #t #t) + + ;; Now we are ready to start the register allocation phase + (expand-real-registers + (append + + ;; First we export code to calculate the multi-binds + (append-map + (lambda (bind) + (let* ((block (statement-block bind)) + (bind-num (statement-bind-num bind)) + (ret (assembly-block-return-reg block)) + (bind-set-reg (list 'local bind-num #f)) + (statements (assembly-block-statements block))) + (if bind-num + (allocate-temps + (if (or (and (not (third bind-set-reg)) (eq? (car ret) 'temp)) + (reg-replace-array-set? ret statements)) + (replace-reg ret bind-set-reg statements) + (append + statements + `(("set" ,bind-set-reg ,ret)))) + (iota num-locals)) ;; This might not be true if an input argument is unused in the function... + (allocate-temps + statements + (iota num-locals))))) + multi-binds) + + ;; Then deal with the call + (let ((if-block (call-if-block call))) + (if if-block + (let ((true-label (unique-label)) + (ret (assembly-block-return-reg if-block))) + (append + ;; The code to check + (allocate-temps + (append + (assembly-block-statements if-block) + `(("find_type" (I 0 #f) "\"Boolean\"") + ("typeof" (I 1 #f) ,ret) + ("ne" (I 0 #f) (I 1 #f) ,true-label) + ("if" ,ret ,true-label))) + (iota num-locals)) + + ;; False code goes first + (allocate-call-regs (call-false-args call) num-locals) + (allocate-temps + (call-false-function call) + (iota (length (call-false-args call)))) + + ;; Now the true code + `((,(string-append true-label ":"))) + (allocate-call-regs (call-true-args call) num-locals) + (allocate-temps + (call-true-function call) + (iota (length (call-true-args call)))))) + + ;; Just a normal call + (append + (allocate-call-regs (call-true-args call) num-locals) + (allocate-temps + (call-true-function call) + (iota (length (call-true-args call))))))))))