~ chicken-core (chicken-5) 7a1e07a263aed861bc0ee24f810e36eb8bc49814
commit 7a1e07a263aed861bc0ee24f810e36eb8bc49814
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jan 20 08:50:25 2012 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jan 20 08:50:25 2012 +0100
actually remove unboxing file
diff --git a/unboxing.scm b/unboxing.scm
deleted file mode 100644
index f9b25313..00000000
--- a/unboxing.scm
+++ /dev/null
@@ -1,560 +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))))
-
-
-;;; unboxed rewrites
-
-(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)))
-
-
-;; 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"))
Trap