Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

465 lines (421 sloc) 15.903 kB
;;;; 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.
(declare (unit unboxing))
(include "compiler-namespace")
(include "tweaks")
(define (d fstr . args)
(when (##sys#fudge 13)
(printf "[debug] ~?~%" 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 (alias v)
(alist-ref v ae eq? v) )
(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 (make-node
'##core#inline_unboxed (list alt)
(reverse iargs))))
(if (and dest (cdr dest))
n2
(let ((tmp (gensym "tu")))
(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) '*)
(unboxed-value? (car args)))
(loop (cdr args)
(cdr anodes)
(cdr atypes)
(cons (car anodes) iargs)))
(else
;; introduce unboxed temporary
(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) '())
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-binding! n)
;; change `(let ((<v> (let (...) <x2>))) <x>)' into
;; `(let (...) (let ((<v> <x2>)) <x>))'
(let* ((subs (node-subexpressions n))
(bnode (first subs))
(bcl (node-class bnode)))
(when (memq bcl '(let ##core#let_unboxed))
(d "straighten 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))))))
(define (straighten-conditional! n)
;; change `(if (let (...) <x1>) <x2> <x3>)' into
;; `(let (...) (if <x1> <x2> <x3>))'
(let* ((subs (node-subexpressions n))
(bnode (first subs))
(bcl (node-class bnode)))
(when (memq bcl '(let ##core#let_unboxed))
(d "straighten 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-call! n)
;; change `(<proc> ... (let (...) <x>) ...)' into
;; `(let (...) (<proc> ... <x> ...))'
(let* ((class (node-class n))
(subs (node-subexpressions n))
(params (node-parameters n))
(proc (first subs))
(args (cdr subs)))
(when (any (lambda (n) (memq (node-class n) '(let ##core#let_unboxed)))
args)
(d "straighten call: ~a" (build-expression-tree proc))
(copy-node!
(let loop ((args args) (newargs '()))
(if (null? args)
(straighten-call!
(make-node class params (cons proc (reverse newargs))))
(let* ((arg (first args))
(aclass (node-class arg))
(asubs (node-subexpressions arg)))
(if (memq aclass '(let ##core#let_unboxed))
(make-node
aclass (node-parameters arg)
(list
(first asubs)
(loop (cdr args) (cons (second asubs) newargs))))
(loop (cdr args) (cons arg newargs))))))
n))
n))
(define (walk n dest udest pass2?)
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
(d "walk: (~a) ~a ~a" pass2? class params)
(case class
((##core#undefined
##core#proc
##core#global-ref
##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)
(let* ((rw1 (##sys#get (symbolify (first params)) '##compiler#unboxed-op))
(rw (and rw1
(or unsafe
(and (fourth rw1)
unchecked-specialized-arithmetic))
rw1))
(args (map (cut walk <> #f rw pass2?) subs)))
(cond ((not rw) #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
(unless pass2?
(for-each
(lambda (a)
(when (and a (car a) (cdr a))
(unboxed! (car a) (cdr a))))
args)
(when dest
(unboxed! dest rtype)))
(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?
(when (and a (cdr a)) ; may have mutated
(copy-node!
(make-node
'##core#unboxed_set! (list (alias var) (cdr a)) subs)
n)))
((and 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-call! n))
#f)
(else
(for-each (o invalidate (cut walk <> #f #f pass2?)) subs)
#f))))
(d "walk lambda: ~a" id)
(walk body #f #f #f)
(walk body #f #f #t)))
(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 #f) ...))))
(define-syntax define-unboxed-arithmetic-ops
(syntax-rules ()
((_ (name atypes rtype alt) ...)
(begin
(register-unboxed-op 'name 'atypes 'rtype 'alt #t) ...))))
(define (register-unboxed-op name atypes rtype alt arithmetic)
(##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype arithmetic)))
;; unboxed rewrites
(define-unboxed-arithmetic-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_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"))
(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"))
Jump to Line
Something went wrong with that request. Please try again.