Commit 88498d35 authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

Type propagators now work with type names, not with C1FORMS (More general and...

Type propagators now work with type names, not with C1FORMS (More general and will allow caching in the future). Implemented type propagators for COS, SIN, TAN, COSH, SINH, TANH, ATAN, SQRT, ABS, ISQRT, LOG, EXP, EXPT.
parent 2657f3b9
......@@ -58,18 +58,27 @@
;;; that some of they have become binary operators.
;;;
(defun maximum-number-type (t1 t2)
(defun maximum-number-type (t1 t2 &optional only-real)
;; 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
;; represent known types, or NUMBER, in other cases.
(let ((t1-eq nil)
(t2-eq nil)
(output nil))
(dolist (i '(FIXNUM INTEGER RATIONAL
#+short-float SHORT-FLOAT SINGLE-FLOAT
DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
COMPLEX NUMBER)
(values (if (and t1-eq t2-eq output)
output
t)
t1 t2))
(output nil)
(default (if only-real 'REAL 'NUMBER))
(types-list (if only-real
'(FIXNUM INTEGER RATIONAL
#+short-float SHORT-FLOAT SINGLE-FLOAT
DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
NUMBER)
'(FIXNUM INTEGER RATIONAL
#+short-float SHORT-FLOAT 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)))
(when (and (null t1-eq) (type>= i t1))
(if (equalp t1 t2)
(setf t2-eq i))
......@@ -77,30 +86,104 @@
(when (and (null t2-eq) (type>= i t2))
(setf t2-eq i output i)))))
(defun arithmetic-propagator (op1 others integer-result)
(loop with op1-type = (c1form-primary-type op1)
with result-type = (maximum-number-type op1-type op1-type)
with arg-types = (list (setf op1-type result-type))
for op2 in others
for op2-type = (c1form-primary-type op2)
do (progn
(multiple-value-setq (result-type op1-type op2-type)
(maximum-number-type op1-type op2-type))
(when (and (or (eq op1-type 'FIXNUM) (eq op1-type 'INTEGER))
(or (eq op2-type 'FIXNUM) (eq op2-type 'INTEGER)))
(setf result-type integer-result))
(setf arg-types (cons op2-type arg-types)
op1-type result-type))
finally (return (values (nreverse arg-types) result-type))))
(defun ensure-number-type (general-type)
(maximum-number-type general-type general-type))
(def-type-propagator * (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(defun ensure-nonrational-type (general-type)
(maximum-number-type 'single-float general-type))
(def-type-propagator + (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(defun ensure-real-type (general-type)
(maximum-number-type 'integer general-type :only-real))
(def-type-propagator - (fname op1 &rest others)
(defun arithmetic-propagator (op1-type others integer-result)
;; Propagates types for an associative operator (we do not care which one).
;; We collect either the types of the arguments or 'NUMBER, as a generic
;; expected type. The output type is computed using the rules of floating
;; point contagion, with the exception that an operation between two
;; integers has type INTEGER-RESULT (integer for *,-,+ and rational else)
(multiple-value-bind (result-type op1-type)
(ensure-number-type op1-type)
(loop with arg-types = (list op1-type)
for x in others
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))
(setf arg-types (cons op2-type arg-types)))
finally (return (values (nreverse arg-types) result-type)))))
(def-type-propagator * (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(copy-type-propagator '* '(+ -))
(def-type-propagator / (fname op1 &rest others)
(arithmetic-propagator op1 others 'rational))
;;;
;;; SPECIAL FUNCTIONS
;;;
(def-type-propagator cos (fname op1-type)
(multiple-value-bind (output-type op1-type)
(ensure-nonrational-type op1-type)
(values (list op1-type) output-type)))
(copy-type-propagator 'cos '(sin tan cosh sinh tanh exp))
(def-type-propagator acos (fname op1-type)
(multiple-value-bind (output-type op1-type)
(ensure-nonrational-type op1-type)
(values (list op1-type) 'NUMBER)))
(def-type-propagator atan (fname op1-type &optional (op2-type t op2-p))
(multiple-value-bind (float-t1 t1)
(ensure-nonrational-type op1-type)
(if op2-p
(multiple-value-bind (result t1 t2)
(maximum-number-type t1 op2-type :only-real)
(values (list t1 t2) result))
(values (list t1) t1))))
(def-type-propagator expt (fname base exponent)
;; Rules:
;; (expt number-type integer) -> number-type
;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
;;
(multiple-value-bind (simplified-exponent exponent)
(ensure-real-type exponent)
(unless (eql simplified-exponent 'integer)
(setf simplified-exponent (ensure-nonrational-type simplified-exponent)))
(multiple-value-bind (result-type base aux)
(maximum-number-type result-type base simplified-exponent)
(values (list base exponent) result-type))))
(def-type-propagator abs (fname arg)
(multiple-value-bind (output arg)
(ensure-number-type arg)
(values (list arg)
(or (getf '((FIXNUM (INTEGER 0 #.MOST-POSITIVE-FIXNUM))
(INTEGER (INTEGER 0 *))
(RATIONAL (RATIONAL 0 *))
(SHORT-FLOAT (SHORT-FLOAT 0 *))
(SINGLE-FLOAT (SINGLE-FLOAT 0 *))
(DOUBLE-FLOAT (DOUBLE-FLOAT 0 *))
(LONG-FLOAT (LONG-FLOAT 0 *))
(REAL (REAL 0 *))
(NUMBER (REAL 0 *)))
output)
output))))
(def-type-propagator sqrt (fname arg)
(multiple-value-bind (output arg)
(ensure-nonrational-type arg)
(values (list arg)
(if (type<= arg '(REAL 0 *)) output 'NUMBER))))
(def-type-propagator isqrt (fname arg)
(if (type<= arg '#1=(integer 0 #.MOST-POSITIVE-FIXNUM))
(values '(#1#) #1#)
(values '(#2=(integer 0 *)) #2#)))
......@@ -385,36 +385,40 @@ as 2^*tagbody-limit* in the worst cases.")
"Input is a lisp type representing a valid subtype of ARRAY. Output is
either the array element type or NIL, denoting that we are not able to
compute it. This version only handles the simplest cases."
(cond ((eq array 'string)
'character)
((eq array 'base-string)
'base-char)
((member array '(array vector simple-vector simple-array))
t)
((atom array)
nil)
((not (member (first array) '(array vector simple-vector simple-array)))
nil)
((null (rest array))
t)
(t
(second array))))
(values (cond ((eq array 'string)
'character)
((eq array 'base-string)
'base-char)
((member array '(array vector simple-vector simple-array))
t)
((atom array)
(setf array 'array))
((not (member (first array)
'(array vector simple-vector simple-array)))
(setf array 'array))
((null (rest array))
t)
(t
(second array)))
array))
(defun get-constant-value (form default)
(if (constantp form)
(cmp-eval form)
default))
(def-type-propagator si::aset (fname obj array &rest indices)
(let* ((array-type (c1form-primary-type array))
(elt-type (or (type-from-array-elt array-type) t)))
(values (list* elt-type array-type (make-list (length indices) :initial-element 'si::index))
(def-type-propagator si::aset (fname obj array-type &rest indices)
(multiple-value-bind (elt-type array-type)
(type-from-array-elt array-type)
(values (list* elt-type array-type
(make-list (length indices) :initial-element 'si::index))
elt-type)))
(def-type-propagator aref (fname array &rest indices)
(let* ((array-type (c1form-primary-type array))
(elt-type (or (type-from-array-elt array-type) t)))
(values (list* array-type (make-list (length indices) :initial-element 'si::index))
(def-type-propagator aref (fname array-type &rest indices)
(multiple-value-bind (elt-type array-type)
(type-from-array-elt array-type)
(values (list* array-type (make-list (length indices)
:initial-element 'si::index))
elt-type)))
(define-compiler-macro make-array (&whole form dimensions
......
......@@ -519,17 +519,17 @@
(in-package "COMPILER")
(defun simple-type-propagator (fname &rest form-types)
(defun simple-type-propagator (fname)
(let ((arg-types (get-arg-types fname))
(return-type (or (get-return-type fname) '(VALUES &REST T))))
(values arg-types return-type)))
(defun propagate-types (fname forms lisp-forms)
(multiple-value-bind (arg-types return-type)
(apply (or (get-sysprop fname 'C1TYPE-PROPAGATOR)
#'simple-type-propagator)
fname
forms)
(let ((propagator (get-sysprop fname 'C1TYPE-PROPAGATOR)))
(if propagator
(apply propagator fname (mapcar #'c1form-primary-type forms))
(simple-type-propagator fname)))
(when arg-types
(do* ((types arg-types (rest types))
(fl forms (rest fl))
......@@ -564,8 +564,17 @@
return-type))
(defmacro def-type-propagator (fname lambda-list &body body)
`(put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,@body)))
(unless (member '&rest lambda-list)
(let ((var (gensym)))
(setf lambda-list (append lambda-list (list '&rest var))
body (list* `(declare (ignorable ,var)) body)))
`(put-sysprop ',fname 'C1TYPE-PROPAGATOR
#'(ext:lambda-block ,fname ,lambda-list ,@body))))
(defun copy-type-propagator (orig dest-list)
(loop with function = (get-sysprop orig 'C1TYPE-PROPAGATOR)
for name in dest-list
do (put-sysprop name 'C1TYPE-PROPAGATOR function)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment