mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-18 08:00:27 -07:00
Code Issues Projects Releases Packages Wiki Activity

Simplify the decision on when to inline -/+/*... fixing a problem with single-argument negation

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-10-11 11:20:54 +02:00
parent e1d0e28890
commit 98c08821c6
1 changed files with 35 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

71
src/cmp/cmpnum.lsp
View file

@ -58,7 +58,7 @@
;;; that some of they have become binary operators.
;;;
(defun maximum-number-type (t1 t2 &optional only-real)
(defun maximum-number-type (t1 t2 &key only-real integer-result)
;; Computes the output type of an operation between number types T1
;; and T2 using the rules of floating point contagion. It returns
;; the type of the result, and the types of T1 and T2, if they
@ -73,16 +73,18 @@
NUMBER)
'(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL))))
(dolist (i types-list
(values (if (and t1-eq t2-eq output) output default)
(if t1-eq t1 default)
(if t2-eq t2 default)))
(dolist (i types-list)
(when (and (null t1-eq) (type>= i t1))
(if (equalp t1 t2)
(setf t2-eq i))
(setf t1-eq i output i))
(when (and (null t2-eq) (type>= i t2))
(setf t2-eq i output i)))))
(setf t2-eq i output i)))
(unless (and t1-eq t2-eq output)
(setf output default))
(when (and integer-result (or (eq output 'fixnum) (eq output 'integer)))
(setf output integer-result))
(values output (if t1-eq t1 default) (if t2-eq t2 default))))
(defun ensure-number-type (general-type)
(maximum-number-type general-type general-type))
@ -91,7 +93,7 @@
(maximum-number-type general-type 'single-float))
(defun ensure-real-type (general-type)
(maximum-number-type general-type 'integer :only-real))
(maximum-number-type general-type 'integer :only-real t))
(defun arithmetic-propagator (op1-type others integer-result)
;; Propagates types for an associative operator (we do not care which one).
@ -106,9 +108,7 @@
for op2-type = x
do (progn
(multiple-value-setq (result-type op1-type op2-type)
(maximum-number-type result-type op2-type))
(when (or (eq result-type 'FIXNUM) (eq result-type 'INTEGER))
(setf result-type integer-result))
(maximum-number-type result-type op2-type :integer-result integer-result))
(setf arg-types (cons op2-type arg-types)))
finally (return (values (nreverse arg-types) result-type)))))
@ -122,30 +122,28 @@
(defun inline-binop (expected-type arg1 arg2 integer-result-type
consing non-consing)
(multiple-value-bind (result t1 t2)
(maximum-number-type (inlined-arg-type arg1) (inlined-arg-type arg2))
(when (member result '(integer fixnum))
(setf result integer-result-type))
(let (c-rep-type)
(if (and (or (and (c-number-type-p result)
(setf c-rep-type (lisp-type->rep-type result)))
(and (policy-assume-right-type)
(c-number-type-p expected-type)
(setf c-rep-type (lisp-type->rep-type expected-type))))
(c-number-type-p t1)
(c-number-type-p t2))
(produce-inline-loc (list arg1 arg2) (list c-rep-type c-rep-type)
(list c-rep-type) non-consing nil t)
(produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
consing nil t)))))
(if (and (policy-assume-right-type)
(c-number-type-p expected-type)
(c-number-type-p (inlined-arg-type arg1))
(c-number-type-p (inlined-arg-type arg2)))
(produce-inline-loc (list arg1 arg2)
(list (lisp-type->rep-type (inlined-arg-type arg1))
(lisp-type->rep-type (inlined-arg-type arg2)))
(list (lisp-type->rep-type expected-type))
non-consing nil t)
(produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
consing nil t)))
(defun inline-arith-unop (arg1 consing non-consing)
(let ((c-rep-type (inlined-arg-rep-type arg1)))
(if (c-number-rep-type-p c-rep-type)
(produce-inline-loc (list arg1) (list c-rep-type)
(list c-rep-type) non-consing nil t)
(produce-inline-loc (list arg1) '(:object) '(:object)
consing nil t))))
(defun inline-arith-unop (expected-type arg1 consing non-consing)
(if (and (policy-assume-right-type)
(c-number-type-p expected-type)
(c-number-type-p (inlined-arg-type arg1)))
(produce-inline-loc (list arg1)
(list (lisp-type->rep-type (inlined-arg-type arg1)))
(list (lisp-type->rep-type expected-type))
non-consing nil t)
(produce-inline-loc (list arg1) '(:object :object) '(:object)
consing nil t)))
(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
(when (null arguments)
@ -162,7 +160,7 @@
(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
(when (null arguments)
(return (inline-arith-unop arg1 "ecl_negate(#0)" "-(#0)")))
(return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 'integer
"ecl_minus(#0,#1)" "(#0)-(#1)")
@ -185,7 +183,8 @@
(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
(when (null arguments)
(return (inline-arith-unop arg1 "ecl_divide(MAKE_FIXNUM(1),(#0))" "1/(#0)")))
(return (inline-arith-unop return-type arg1
"ecl_divide(MAKE_FIXNUM(1),(#0))" "1/(#0)")))
(loop for arg2 = (pop arguments)
for result = (inline-binop return-type arg1 arg2 'rational
"ecl_divide(#0,#1)" "(#0)/(#1)")
@ -214,7 +213,7 @@
(ensure-nonrational-type op1-type)
(if op2-p
(multiple-value-bind (result t1 t2)
(maximum-number-type t1 op2-type :only-real)
(maximum-number-type t1 op2-type :only-real t)
(values (list t1 t2) result))
(values (list t1) t1))))