[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] remove unboxing
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] remove unboxing |
|
Date: |
Wed, 21 Dec 2011 21:37:22 +0100 (CET) |
The attached patch removes the unboxing pass from the compiler. It
never worked reliably and has evolved into an unmaintainable
mess. This will result in a reduction of runtime performance for
unsafe floating-point intensive code.
>From 477976e29fa7ba09f86bff410f6747c9d0ebd822 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Wed, 21 Dec 2011 09:03:53 +0100
Subject: [PATCH] removed unboxing completely
---
batch-driver.scm | 7 -
c-platform.scm | 2 +-
chicken.scm | 4 +-
compiler-namespace.scm | 1 -
csc.scm | 3 +-
distribution/manifest | 3 -
manual/Using the compiler | 6 +-
rules.make | 2 +-
support.scm | 2 -
tests/compiler-tests-3.scm | 52 ----
tests/runtests.bat | 6 -
tests/runtests.sh | 4 -
unboxing.scm | 559 --------------------------------------------
13 files changed, 6 insertions(+), 645 deletions(-)
delete mode 100644 tests/compiler-tests-3.scm
delete mode 100644 unboxing.scm
diff --git a/batch-driver.scm b/batch-driver.scm
index cd1cd60..0521c74 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -90,7 +90,6 @@
(uunit (memq 'unit options))
(a-only (memq 'analyze-only options))
(dynamic (memq 'dynamic options))
- (unbox (memq 'unboxing options))
(do-scrutinize (memq 'scrutinize options))
(dumpnodes #f)
(start-time #f)
@@ -649,12 +648,6 @@
(> (- (cputime) start-time)
funny-message-timeout))
(display "(don't worry - still compiling...)\n") )
(print-node "closure-converted" '|9| node2)
- (when (and unbox unsafe)
- (debugging 'p "performing unboxing")
- (begin-time)
- (perform-unboxing! node2)
- (end-time "unboxing")
- (print-node "unboxing" '|U| node2) )
(when a-only (exit 0))
(begin-time)
(receive
diff --git a/c-platform.scm b/c-platform.scm
index fb9c4bd..b2161d4 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -93,7 +93,7 @@
no-parentheses-synonyms no-symbol-escape r5rs-syntax
emit-all-import-libraries
strict-types clustering
lambda-lift ; OBSOLETE
- setup-mode unboxing no-module-registration) )
+ setup-mode no-module-registration) )
(define valid-compiler-options-with-argument
'(debug
diff --git a/chicken.scm b/chicken.scm
index e353a3e..1bf2591 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -28,7 +28,7 @@
(declare
(uses chicken-syntax chicken-ffi-syntax
srfi-1 srfi-4 utils files extras data-structures support
- compiler optimizer unboxing compiler-syntax scrutinizer driver platform
backend
+ compiler optimizer compiler-syntax scrutinizer driver platform backend
srfi-69))
@@ -104,7 +104,6 @@
'inline
'inline-global
'specialize
- 'unboxing
;XXX 'clustering
'local 'unsafe
options) ) )
@@ -123,7 +122,6 @@
'inline
'inline-global
'clustering
- 'unboxing
options) ) ) ) )
(loop (cdr rest)) ) )
((eq? 'debug-level o)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 9cf865f..de11811 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -222,7 +222,6 @@
perform-high-level-optimizations
perform-inlining!
perform-pre-optimization!
- perform-unboxing!
posq
postponed-initforms
pprint-expressions-to-file
diff --git a/csc.scm b/csc.scm
index 88992ca..e479ae7 100644
--- a/csc.scm
+++ b/csc.scm
@@ -137,7 +137,7 @@
-analyze-only -keep-shadowed-macros -inline-global -ignore-repository
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
- -emit-all-import-libraries -setup-mode -unboxing -no-elevation
-no-module-registration
+ -emit-all-import-libraries -setup-mode -no-elevation
-no-module-registration
-no-procedure-checks-for-usual-bindings -module
-specialize -strict-types -clustering
-lambda-lift ; OBSOLETE
@@ -383,7 +383,6 @@ Usage: #{csc} FILENAME | OPTION ...
-inline enable inlining
-inline-limit LIMIT set inlining threshold
-inline-global enable cross-module inlining
- -unboxing use unboxed temporaries if possible
-specialize perform type-based specialization of
primitive calls
-n -emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
diff --git a/distribution/manifest b/distribution/manifest
index 03d9e35..6c02c34 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -27,7 +27,6 @@ lolevel.c
optimizer.c
compiler-syntax.c
scrutinizer.c
-unboxing.c
irregex.c
posixunix.c
posixwin.c
@@ -76,7 +75,6 @@ lolevel.scm
optimizer.scm
compiler-syntax.scm
scrutinizer.scm
-unboxing.scm
irregex.scm
irregex-core.scm
irregex-utils.scm
@@ -109,7 +107,6 @@ tests/arithmetic-test.32.expected
tests/arithmetic-test.64.expected
tests/library-tests.scm
tests/compiler-tests.scm
-tests/compiler-tests-3.scm
tests/inlining-tests.scm
tests/locative-stress-test.scm
tests/r4rstest.scm
diff --git a/manual/Using the compiler b/manual/Using the compiler
index fbc1cab..0d4c09a 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -125,8 +125,8 @@ the source text should be read from standard input.
-optimize-level 1 is equivalent to -optimize-leaf-routines
-optimize-level 2 is equivalent to -optimize-leaf-routines
-inline
-optimize-level 3 is equivalent to -optimize-leaf-routines
-local -inline -inline-global -specialize
- -optimize-level 4 is equivalent to -optimize-leaf-routines
-local -inline -inline-global -unboxing -specialize -unsafe
- -optimize-level 5 is equivalent to -optimize-leaf-routines
-block -inline -inline-global -unboxing -specialize -unsafe -disable-interrupts
-no-trace -no-lambda-info
+ -optimize-level 4 is equivalent to -optimize-leaf-routines
-local -inline -inline-global -specialize -unsafe
+ -optimize-level 5 is equivalent to -optimize-leaf-routines
-block -inline -inline-global -specialize -unsafe -disable-interrupts -no-trace
-no-lambda-info
; -output-file FILENAME : Specifies the pathname of the generated C file.
Default is {{FILENAME.c}}.
@@ -161,8 +161,6 @@ the source text should be read from standard input.
; -to-stdout : Write compiled code to standard output instead of creating a
{{.c}} file.
-; -unboxing : try to use unboxed temporaries for numerical operations. This
optimization is only effective in unsafe mode.
-
; -unit NAME : Compile this file as a library unit. Equivalent to {{-prelude
"(declare (unit NAME))"}}
; -unsafe : Disable runtime safety checks.
diff --git a/rules.make b/rules.make
index f19972f..7ec8613 100644
--- a/rules.make
+++ b/rules.make
@@ -44,7 +44,7 @@ LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
COMPILER_OBJECTS_1 = \
- chicken batch-driver compiler optimizer compiler-syntax scrutinizer
unboxing support \
+ chicken batch-driver compiler optimizer compiler-syntax scrutinizer
support \
c-platform c-backend
COMPILER_OBJECTS = $(COMPILER_OBJECTS_1:=$(O))
COMPILER_STATIC_OBJECTS = $(COMPILER_OBJECTS_1:=-static$(O))
diff --git a/support.scm b/support.scm
index 97ba03a..c02dc89 100644
--- a/support.scm
+++ b/support.scm
@@ -1670,7 +1670,6 @@ Usage: chicken FILENAME OPTION ...
-inline-limit LIMIT set inlining threshold
-inline-global enable cross-module inlining
-specialize perform type-based specialization of
primitive calls
- -unboxing use unboxed temporaries if possible
-emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
-consult-inline-file FILENAME explicitly load inline file
@@ -1740,7 +1739,6 @@ Available debugging options:
S show applications of compiler syntax
T show expressions after converting to node tree
P show expressions after specialization
- U show expressions after unboxing
M show syntax-/runtime-requirements
1 show source expressions
2 show canonicalized expressions
diff --git a/tests/compiler-tests-3.scm b/tests/compiler-tests-3.scm
deleted file mode 100644
index 65164d1..0000000
--- a/tests/compiler-tests-3.scm
+++ /dev/null
@@ -1,52 +0,0 @@
-;;; compiler-tests-3.scm - tests for unboxing
-
-
-;;; unboxing introduced binding in test-position of conditional
-
-;;; MBROT -- Generation of Mandelbrot set fractal.
-
-(define (count r i step x y)
-
- (let ((max-count 64)
- (radius^2 16.0))
-
- (let ((cr (fp+ r (fp* (exact->inexact x) step)))
- (ci (fp+ i (fp* (exact->inexact y) step))))
-
- (let loop ((zr cr)
- (zi ci)
- (c 0))
- (if (= c max-count)
- c
- (let ((zr^2 (fp* zr zr))
- (zi^2 (fp* zi zi)))
- (if (fp> (fp+ zr^2 zi^2) radius^2)
- c
- (let ((new-zr (fp+ (fp- zr^2 zi^2) cr))
- (new-zi (fp+ (fp* 2.0 (fp* zr zi)) ci)))
- (loop new-zr new-zi (+ c 1))))))))))
-
-(define (mbrot matrix r i step n)
- (let loop1 ((y (- n 1)))
- (if (>= y 0)
- (let loop2 ((x (- n 1)))
- (if (>= x 0)
- (begin
- (vector-set! (vector-ref matrix x) y (count r i step x y))
- (loop2 (- x 1)))
- (loop1 (- y 1)))))))
-
-(define (test n)
- (let ((matrix (make-vector n)))
- (let loop ((i (- n 1)))
- (if (>= i 0)
- (begin
- (vector-set! matrix i (make-vector n))
- (loop (- i 1)))))
- (mbrot matrix -1.0 -0.5 0.005 n)
- (vector-ref (vector-ref matrix 0) 0)))
-
-(define (main . args)
- (let ((r (test 75)))
- (unless (equal? r 5)
- (error "incorrect result: " r))))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 1b82aa9..3e8e7ab 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -27,12 +27,6 @@ if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
-echo ======================================== compiler tests (unboxing) ...
-%compile% compiler-tests-3.scm -unsafe -unboxing
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
echo ======================================== compiler inlining tests ...
%compile% inlining-tests.scm -optimize-level 3
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index dc5b3dd..a629ffc 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -63,10 +63,6 @@ echo "======================================== compiler
tests ..."
$compile compiler-tests.scm
./a.out
-echo "======================================== compiler tests (unboxing) ..."
-$compile compiler-tests-3.scm -unsafe -unboxing
-./a.out
-
echo "======================================== compiler inlining tests ..."
$compile inlining-tests.scm -optimize-level 3
./a.out
diff --git a/unboxing.scm b/unboxing.scm
deleted file mode 100644
index a6da5d3..0000000
--- a/unboxing.scm
+++ /dev/null
@@ -1,559 +0,0 @@
-;;;; unboxing.scm - The CHICKEN Scheme compiler (local flow-analysis with
number boxing/unboxing)
-;
-; Copyright (c) 2009-2011, The Chicken Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-;; I don't understand this code anymore. It needs cleanup and simplification.
-
-
-(declare
- (unit unboxing)
- (hide d-depth))
-
-
-(include "compiler-namespace")
-(include "tweaks")
-
-
-(define d-depth 0)
-
-(define (d fstr . args)
- (when (##sys#fudge 13)
- (printf "[debug] ~a~?~%" (make-string d-depth #\space) fstr args)) )
-
-(define-syntax d (syntax-rules () ((_ . _) (void))))
-
-
-(define (perform-unboxing! node)
- (let ((stats (make-vector 301 '()))
- (any-rewrites #f))
-
- ;; walk nodes in lambda and mark unboxed variables
- (define (walk-lambda id e body)
- (let ((ae '()))
-
- (define (boxed! v) ; boxed is sticky
- (d "boxing ~a" v )
- (cond ((assq v e) =>
- (lambda (a)
- (set-cdr! a #f) ) )
- (else (set! e (alist-cons v #f e)))))
-
- (define (unboxed! v t)
- (d "unboxing ~a -> ~a" v t)
- (cond ((assq v e) =>
- (lambda (a)
- (if (cdr a)
- (let ((t2 (and (eq? (cdr a) t) t)))
- (if t2
- (set-cdr! a t2)
- (set! e (alist-cons v #f e))))
- (set-cdr! e (alist-cons v #f e)))))
- (else
- (set! ae (alist-cons v (gensym "tu") ae))
- (set! e (alist-cons v t e)))))
-
- (define (unboxed? v)
- (and-let* ((a (assq v e)))
- (cdr a)))
-
- (define (unboxed-value? x)
- (and x (cdr x)))
-
- (define (invalidate r) ; if result is variable, mark it boxed
- (when (and (pair? r) (car r))
- (boxed! (car r))))
-
- (define (literal-type x)
- (cond ((char? x) 'char)
- ((flonum? x) 'flonum)
- ((fixnum? x) 'fixnum)
- ((boolean? x) 'bool)
- (else #f)))
-
- (define (unboxed-literal x)
- (cond ((char? x)
- (sprintf "\'\\~a\'" (string-pad (number->string (char->integer
x) 8) 3 #\0)))
- ((number? x) (number->string x))
- ((boolean? x) (if x "1" "0"))
- (else (bomb "(unboxing) unexpected literal type" x))))
-
- (define (alias v)
- (alist-ref v ae eq? v) )
-
- ;; merge results at control-flow join (i.e. conditional)
- (define (merge r1 r2)
- (cond ((or (not r1) (not (cdr r1)))
- (invalidate r2)
- #f)
- ((or (not r2) (not (cdr r2)))
- (invalidate r1)
- #f)
- ((equal? r1 r2) r1)
- ((eq? (cdr r1) (cdr r2))
- (cons #f (cdr r1)))
- (else #f)))
-
- (define (rewrite! n alt anodes avals atypes0 rtype dest)
- (d "rewrite: ~a -> ~a (dest: ~a)" (first (node-parameters n)) alt
dest)
- (let ((s (symbolify alt)))
- (set! any-rewrites #t)
- (##sys#hash-table-set!
- stats s (add1 (or (##sys#hash-table-ref stats s) 0))))
- (copy-node!
- (let loop ((args avals) (anodes anodes) (atypes atypes0) (iargs '()))
- (cond ((null? args)
- (let ((n2 (straighten-form!
- (make-node
- '##core#inline_unboxed (list alt)
- (reverse iargs)))))
- (if (and dest (cdr dest))
- n2
- (let ((tmp (gensym "tu")))
- ;; introduce unboxed temporary for result
- (make-node
- '##core#let_unboxed (list tmp rtype)
- (list
- n2
- (case rtype
- ((flonum)
- (make-node
- '##core#inline_allocate (list "C_a_i_flonum"
4) ; hardcoded size
- (list (make-node '##core#unboxed_ref (list
tmp rtype) '()))))
- ((int)
- (make-node
- '##core#inline_allocate (list
"C_a_int_to_num" 4) ; hardcoded size
- (list (make-node '##core#unboxed_ref (list
tmp rtype) '()))))
- ((pointer)
- (make-node
- '##core#inline_allocate (list
"C_a_i_mpointer" 2) ; hardcoded size
- (list (make-node '##core#unboxed_ref (list
tmp rtype) '()))))
- ((char fixnum)
- (make-node
- '##core#inline
- (list (if (eq? rtype 'char)
"C_make_character" "C_fix"))
- (list (make-node
- '##core#unboxed_ref
- (list tmp rtype) '()))))
- ((bool)
- (make-node
- '##core#inline '("C_mk_bool")
- (list
- (make-node '##core#unboxed_ref (list tmp
rtype) '()))))
- ((*) (bomb "unboxed type `*' not allowed as
result"))
- (else (bomb "invalid unboxed type"
rtype)))))))))
- ((or (eq? (car atypes) '*) ; already unboxed argument ->
just pass it unchanged
- (unboxed-value? (car args)))
- (loop (cdr args)
- (cdr anodes)
- (cdr atypes)
- (cons (car anodes) iargs)))
- ;; if literal of correct type, pass directly as
##core#unboxed_ref
- ((and (eq? (node-class (car anodes)) 'quote)
- (eq? (literal-type (first (node-parameters (car
anodes)))) (car atypes)))
- ;;XXX what if type does not match? error? warning?
- (loop (cdr args)
- (cdr anodes)
- (cdr atypes)
- (cons (make-node
- '##core#unboxed_ref
- (list (unboxed-literal (first (node-parameters
(car anodes))))
- (car atypes))
- '())
- iargs)))
- (else
- ;; introduce unboxed temporary for argument
- ;;
- ;;XXX this is suboptimal: we could reuse unboxed temporaries
- ;; that are in scope. Currently the same are will be
unboxed
- ;; repeatedly.
- ;; (But we must make sure there are not intermediate side
- ;; effects - possibly only reuse unboxed value if
unassigned
- ;; local or lexical variable ref, or literal)
- ;;
- ;; (See also comment below, after "walk-lambda")
- (let ((tmp (gensym "tu")))
- (make-node
- '##core#let_unboxed (list tmp (car atypes))
- (list (make-node
- '##core#inline
- (list (case (car atypes)
- ((char) "C_character_code")
- ((fixnum) "C_unfix")
- ((flonum) "C_flonum_magnitude")
- ((int) "C_num_to_int")
- ((pointer) "C_pointer_address")
- ((bool) "C_truep")
- ((*) "C_id")
- (else
- (bomb "invalid unboxed argument type"
(car atypes)))))
- (list (car anodes)))
- (loop (cdr args)
- (cdr anodes)
- (cdr atypes)
- (cons (make-node '##core#unboxed_ref (list
tmp (car atypes)) '())
- iargs))))))))
- n)
- (straighten-binding! n))
-
- (define (rebind-unboxed! n t)
- (let ((var (alias (first (node-parameters n)))))
- (node-class-set! n '##core#let_unboxed)
- (node-parameters-set! n (list var t))
- (straighten-binding! n) ))
-
- (define (straighten! n)
- (case (node-class n)
- ((let ##core#let_unboxed) (straighten-binding! n))
- ((if) (straighten-conditional! n))
- (else (straighten-form! n))))
-
- (define (straighten-binding! n)
- ;; change `(let ((<v> (let (...) <x2>))) <x>)' into
- ;; `(let (...) (let ((<v> <x2>)) <x>))'
- ;; (also for "##core#let_unboxed")
- (let* ((subs (node-subexpressions n))
- (bnode (first subs))
- (bcl (node-class bnode)))
- (when (memq bcl '(let ##core#let_unboxed))
- (d "straightening binding: ~a -> ~a" (node-parameters n)
(node-parameters bnode))
- (copy-node!
- (make-node
- bcl
- (node-parameters bnode)
- (let ((bsubs (node-subexpressions bnode)))
- (list (first bsubs)
- (make-node
- (node-class n)
- (node-parameters n)
- (list (second bsubs)
- (second subs))))))
- n)
- ;;(pp (build-expression-tree n))
- (straighten-binding! n)
- (straighten-binding! (second (node-subexpressions n))))
- n))
-
- (define (straighten-conditional! n)
- ;; change `(if (let (...) <x1>) <x2> <x3>)' into
- ;; `(let (...) (if <x1> <x2> <x3>))'
- ;; (also for "##core#let_unboxed")
- (let* ((subs (node-subexpressions n))
- (bnode (first subs))
- (bcl (node-class bnode)))
- (when (memq bcl '(let ##core#let_unboxed))
- (d "straightening conditional: ~a" (node-parameters bnode))
- (copy-node!
- (make-node
- bcl
- (node-parameters bnode)
- (let ((bsubs (node-subexpressions bnode)))
- (list (first bsubs)
- (make-node
- (node-class n)
- (node-parameters n)
- (cons (second bsubs) (cdr subs))))))
- n)
- (straighten-conditional! (second (node-subexpressions n)))
- ;;(pp (build-expression-tree n))
- (straighten-binding! n))))
-
- (define (straighten-form! n)
- ;; change `(<form> ... (let (...) <x>) ...)' to
- ;; `(let (...) (<form> ... <x> ...))'
- ;; - also for `##core#let_unboxed'
- (let ((class (node-class n))
- (subs (node-subexpressions n))
- (params (node-parameters n))
- (f #f))
- (let loop ((args subs) (newargs '()) (wrap identity))
- (cond ((null? args)
- (let ((n2 (wrap
- ((if f straighten! identity)
- (make-node class params (reverse newargs))))))
- (when f
- (d "straightening form (~a): ~a" class params)
- (let ((n2 (straighten-binding! n2)))
-#|
- (print "---\n") ;XXX
- (pp (build-expression-tree n))
- (print " ->\n")
-|#
- (copy-node! n2 n)
-#|
- (pp (build-expression-tree n))
- (print "---\n")
-|#
- ))
- n))
- ((memq (node-class (car args)) '(let ##core#let_unboxed))
- (let* ((arg (car args))
- (subs2 (node-subexpressions arg)))
- (set! f #t)
- (loop (cdr args)
- (cons (second subs2) newargs)
- (lambda (body)
- (wrap
- (make-node
- (node-class arg)
- (node-parameters arg)
- (list (first subs2) body)))))))
- (else (loop (cdr args) (cons (car args) newargs) wrap))))))
-
- ;; walk node and return either "(<var> . <type>)" or #f
- ;; - at second pass: rewrite "##core#inline[_allocate]" nodes
- (define (walk n dest udest pass2?)
- (let ((subs (node-subexpressions n))
- (params (node-parameters n))
- (class (node-class n)) )
- (d "walk: (~a) ~a ~a" (if pass2? 2 1) class params)
- (set! d-depth (add1 d-depth))
- (let ((result
- (case class
-
- ((##core#undefined
- ##core#proc
- ##core#inline_ref
- ##core#inline_loc_ref) #f)
-
- ((##core#lambda ##core#direct_lambda)
- (decompose-lambda-list
- (third params)
- (lambda (vars argc rest)
- (unless pass2?
- (walk-lambda
- (first params)
- (map (cut cons <> #f) vars)
- (first subs)) )
- #f)))
-
- ((##core#variable)
- (let* ((v (first params))
- (a (assq v e)))
- (cond (pass2?
- (when (and a (cdr a))
- (copy-node!
- (make-node
- '##core#unboxed_ref
- (list (alias v) (cdr a))
- '())
- n)))
- ((not a) #f) ; global
- ((not udest) (boxed! v)))
- a))
-
- ((##core#inline ##core#inline_allocate
##core#inline_unboxed)
- (let* ((rw1 (##sys#get (symbolify (first params))
'##compiler#unboxed-op))
- (rw (and unsafe rw1))
- (args (map (cut walk <> #f rw pass2?) subs)))
- ;; rewrite inline operation to unboxed one, if possible
- (cond ((not rw)
- (straighten-form! n)
- #f)
- ((or (not pass2?)
- (and dest (unboxed? dest))
- (any unboxed-value? args))
- (let ((alt (first rw))
- (atypes (second rw))
- (rtype (third rw)))
- ;; result or arguments are unboxed - rewrite
node to alternative
- (when pass2?
- (rewrite!
- n alt subs args atypes rtype
- (and dest (assq dest e))))
- (cons #f rtype)) )
- (else
- (let ((rtype (third rw)))
- ;; mark argument-vars and dest as unboxed if
alternative exists
- (cond ((not pass2?)
- (for-each
- (lambda (a)
- (when (and a (car a) (cdr a))
- (unboxed! (car a) (cdr a))))
- args)
- (when dest
- (unboxed! dest rtype)))
- (else (straighten-form! n)))
- (cons #f rtype))))))
-
- ((let)
- (let* ((v (first params))
- (r1 (walk (first subs) v #t pass2?)))
- (when (and (not pass2?) r1 (cdr r1))
- (unboxed! (first params) (cdr r1)))
- (let ((r (walk (second subs) dest udest pass2?)))
- (when pass2?
- (let ((a (assq v e)))
- (if (and a (cdr a))
- (rebind-unboxed! n (cdr a))
- (straighten-binding! n))))
- r)))
-
- ((set!)
- (let* ((var (first params))
- (a (assq var e))
- (val (walk (first subs) var (and a (cdr a))
pass2?)))
- (cond (pass2?
- (cond ((and a (cdr a)) ; may have mutated in
walk above
- (copy-node!
- (make-node
- '##core#unboxed_set! (list (alias var)
(cdr a)) subs)
- n)
- (straighten-form! n))
- (else
- (straighten-form! n))))
- ((and a val (cdr val))
- (unboxed! var (cdr val)))
- (else
- (boxed! var)
- (invalidate val) ) )
- #f))
-
- ((quote) #f)
-
- ((if ##core#cond)
- (invalidate (walk (first subs) #f #f pass2?))
- (straighten-conditional! n)
- (let ((r1 (walk (second subs) dest udest pass2?))
- (r2 (walk (third subs) dest udest pass2?)))
- (merge r1 r2)))
-
- ((##core#switch)
- (invalidate (walk (first subs) #f #f pass2?))
- (do ((clauses (cdr subs) (cddr clauses))
- (r 'none
- (if (eq? r 'none)
- (walk (second clauses) dest udest pass2?)
- (merge r (walk (second clauses) dest udest
pass2?)))))
- ((null? (cdr clauses))
- (merge r (walk (car clauses) dest udest pass2?))) ) )
-
- ((##core#call ##core#direct_call)
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- (when pass2?
- (straighten-form! n))
- #f)
-
- (else
- (for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
- #f))))
-
- (set! d-depth (sub1 d-depth))
- result)))
-
- (d "walk lambda: ~a (pass 1)" id)
- ;; walk once and mark boxed/unboxed variables in environment
- (walk body #f #f #f)
- ;; walk a second time and rewrite
- (d "walk lambda: ~a (pass 2)" id)
- (walk body #f #f #t)))
-
- ;;XXX Note: lexical references ("##core#ref" nodes) are unboxed
- ;; repeatedly which is sub-optimal: the unboxed temporaries bound
- ;; via "##core#let_unboxed" could be re-used in many cases.
- ;; One possible approach would be an additional "cleanup" pass
- ;; that replaces
- ;;
- ;; (##core#let_unboxed (TU TYPE) X (##core#ref VAR (SLOT)) Y)
- ;;
- ;; with
- ;;
- ;; (##core#let_unboxed (TU TYPE) (##core#unboxed_ref TU1) Y)
-
- (walk-lambda #f '() node)
- (when (and any-rewrites
- (debugging 'o "unboxed rewrites:"))
- (##sys#hash-table-for-each
- (lambda (k v)
- (printf " ~a\t~a~%" k v) )
- stats))))
-
-(define-syntax define-unboxed-ops
- (syntax-rules ()
- ((_ (name atypes rtype alt) ...)
- (begin
- (register-unboxed-op 'name 'atypes 'rtype 'alt) ...))))
-
-(define (register-unboxed-op name atypes rtype alt)
- (##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype)))
-
-
-;;; unboxed rewrites
-
-;; arithmetic
-(define-unboxed-ops
- (C_a_i_flonum_plus (flonum flonum) flonum "C_ub_i_flonum_plus")
- (C_a_i_flonum_difference (flonum flonum) flonum "C_ub_i_flonum_difference")
- (C_a_i_flonum_times (flonum flonum) flonum "C_ub_i_flonum_times")
- (C_a_i_flonum_quotient (flonum flonum) flonum "C_ub_i_flonum_quotient")
- (C_a_i_flonum_quotient_checked (flonum flonum) flonum
"C_ub_i_flonum_quotient_checked")
- (C_u_i_fpintegerp (flonum) bool "C_ub_i_fpintegerp")
- (C_flonum_equalp (flonum flonum) bool "C_ub_i_flonum_equalp")
- (C_flonum_greaterp (flonum flonum) bool "C_ub_i_flonum_greaterp")
- (C_flonum_lessp (flonum flonum) bool "C_ub_i_flonum_lessp")
- (C_flonum_greater_or_equal_p (flonum flonum) bool
"C_ub_i_flonum_greater_or_equal_p")
- (C_flonum_less_or_equal_p (flonum flonum) bool
"C_ub_i_flonum_less_or_equal_p")
- (C_a_i_flonum_sin (flonum) flonum "C_sin")
- (C_a_i_flonum_cos (flonum) flonum "C_cos")
- (C_a_i_flonum_tan (flonum) flonum "C_tab")
- (C_a_i_flonum_asin (flonum) flonum "C_asin")
- (C_a_i_flonum_acos (flonum) flonum "C_acos")
- (C_a_i_flonum_atan (flonum) flonum "C_atan")
- (C_a_i_flonum_atan2 (flonum flonum) flonum "C_atan2")
- (C_a_i_flonum_exp (flonum) flonum "C_exp")
- (C_a_i_flonum_expt (flonum flonum) flonum "C_pow")
- (C_a_i_flonum_log (flonum) flonum "C_log")
- (C_a_i_flonum_sqrt (flonum) flonum "C_sqrt")
- (C_a_i_flonum_abs (flonum) flonum "C_fabs")
- (C_a_i_flonum_truncate (flonum) flonum "C_trunc")
- (C_a_i_flonum_ceiling (flonum) flonum "C_ceil")
- (C_a_i_flonum_floor (flonum) flonum "C_floor")
- (C_a_i_flonum_round (flonum) flonum "C_round")
- (C_a_i_fix_to_flo (fixnum) flonum "C_cast_to_flonum"))
-
-;; others
-(define-unboxed-ops
- (C_u_i_f32vector_set (* fixnum flonum) fixnum "C_ub_i_f32vector_set")
- (C_u_i_f64vector_set (* fixnum flonum) fixnum "C_ub_i_f64vector_set")
- (C_a_i_f32vector_ref (* fixnum) flonum "C_ub_i_f32vector_ref")
- (C_a_i_f64vector_ref (* fixnum) flonum "C_ub_i_f64vector_ref")
- (C_a_u_i_pointer_inc (pointer fixnum) pointer "C_ub_i_pointer_inc")
- (C_pointer_eqp (pointer pointer) bool "C_ub_i_pointer_eqp")
- (C_u_i_pointer_u8_ref (pointer) fixnum "C_ub_i_pointer_u8_ref")
- (C_u_i_pointer_s8_ref (pointer) fixnum "C_ub_i_pointer_s8_ref")
- (C_u_i_pointer_u16_ref (pointer) fixnum "C_ub_i_pointer_u16_ref")
- (C_u_i_pointer_s16_ref (pointer) fixnum "C_ub_i_pointer_s16_ref")
- (C_u_i_pointer_u32_ref (pointer) fixnum "C_ub_i_pointer_u32_ref")
- (C_u_i_pointer_s32_ref (pointer) fixnum "C_ub_i_pointer_s32_ref")
- (C_u_i_pointer_f32_ref (pointer) flonum "C_ub_i_pointer_f32_ref")
- (C_u_i_pointer_f64_ref (pointer) flonum "C_ub_i_pointer_f64_ref")
- (C_u_i_pointer_u8_set (pointer fixnum) fixnum "C_ub_i_pointer_u8_set")
- (C_u_i_pointer_s8_set (pointer fixnum) fixnum "C_ub_i_pointer_s8_set")
- (C_u_i_pointer_u16_set (pointer fixnum) fixnum "C_ub_i_pointer_u16_set")
- (C_u_i_pointer_s16_set (pointer fixnum) fixnum "C_ub_i_pointer_s16_set")
- (C_u_i_pointer_u32_set (pointer fixnum) fixnum "C_ub_i_pointer_u32_set")
- (C_u_i_pointer_s32_set (pointer fixnum) fixnum "C_ub_i_pointer_s32_set")
- (C_u_i_pointer_f32_set (pointer flonum) flonum "C_ub_i_pointer_f32_set")
- (C_u_i_pointer_f64_set (pointer flonum) flonum "C_ub_i_pointer_f64_set")
- (C_null_pointerp (pointer) bool "C_ub_i_null_pointerp"))
--
1.7.6.msysgit.0
- [Chicken-hackers] [PATCH] remove unboxing,
Felix <=