cmpnum.lsp 10.4 KB
Newer Older
jgarcia's avatar
jgarcia committed
1
2
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;;;; CMPNUM -- Optimizer for numerical expressions.

;;;;  Copyright (c) 2005, Juan Jose Garcia Ripoll
;;;;
;;;;    ECoLisp is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

(in-package "COMPILER")

(defun simplify-arithmetic (operator args whole)
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
  (if (every #'numberp args)
      (apply operator args)
      (let ((l (length args)))
        (cond ((> l 2)
               (simplify-arithmetic
                operator
                (list* (simplify-arithmetic operator
                                            (list (first args) (second args))
                                            nil)
                       (cddr args))
                nil))
              ((= l 2)
               (or whole (list* operator args)))
              ((= l 1)
               (if (or (eq operator '*) (eq operator '+))
                   (first args)
                   (or whole (list* operator args))))
              ((eq operator '*)
               1)
              ((eq operator '+)
               0)
              (t
               (error 'simple-program-error
                      :format-error "Wrong number of arguments for operator ~a in ~a"
41
42
                      :format-arguments (list operator (or whole
                                                           (list* operator args)))))))))
43
44
45
46
47
48
49
50
51
52
53
54
55

(define-compiler-macro * (&whole all &rest args)
  (simplify-arithmetic '* args all))

(define-compiler-macro + (&whole all &rest args)
  (simplify-arithmetic '+ args all))

(define-compiler-macro / (&whole all &rest args)
  (simplify-arithmetic '/ args all))

(define-compiler-macro - (&whole all &rest args)
  (simplify-arithmetic '- args all))

56
57
58
59
60
;;;
;;; The following are type propagators for arithmetic operations. Note
;;; that some of they have become binary operators.
;;;

61
(defun maximum-number-type (t1 t2 &key only-real integer-result)
62
63
64
65
  ;; 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.
66
67
  (let ((t1-eq nil)
        (t2-eq nil)
68
69
70
        (output nil)
        (default (if only-real 'REAL 'NUMBER))
        (types-list (if only-real
71
                        '(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
72
73
                          DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
                          NUMBER)
74
                        '(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
75
                          DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL))))
76
    (dolist (i types-list)
77
78
79
      (when (and (null t1-eq) (type>= i t1))
        (if (equalp t1 t2)
            (setf t2-eq i))
80
        (setf t1-eq i output i))
81
      (when (and (null t2-eq) (type>= i t2))
82
83
84
85
86
87
        (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))))
88

89
90
(defun ensure-number-type (general-type)
  (maximum-number-type general-type general-type))
91

92
(defun ensure-nonrational-type (general-type)
93
  (maximum-number-type general-type 'single-float))
94

95
(defun ensure-real-type (general-type)
96
  (maximum-number-type general-type 'integer :only-real t))
97

98
99
100
101
102
103
104
105
106
107
108
109
110
(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)
111
              (maximum-number-type result-type op2-type :integer-result integer-result))
112
113
114
115
            (setf arg-types (cons op2-type arg-types)))
       finally (return (values (nreverse arg-types) result-type)))))

(def-type-propagator * (fname op1 &rest others)
116
  (arithmetic-propagator op1 others 'integer))
117

118
119
(copy-type-propagator '* '(+ -))

120
121
(def-type-propagator / (fname op1 &rest others)
  (arithmetic-propagator op1 others 'rational))
122

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
(defun inline-binop (expected-type arg1 arg2 consing non-consing)
  (let ((arg1-type (inlined-arg-type arg1))
	(arg2-type (inlined-arg-type arg2)))
    (if (and (policy-assume-right-type)
	     (c-number-type-p expected-type)
	     (c-number-type-p arg1-type)
	     (c-number-type-p arg2-type))
	;; The input arguments have to be coerced to a C
	;; type that fits the output, to avoid overflow which
	;; would happen if we used say, long c = (int)a * (int)b
	;; as the output would be an integer, not a long.
	(let* ((arg1-rep (lisp-type->rep-type arg1-type))
	       (arg2-rep (lisp-type->rep-type arg2-type))
	       (out-rep (lisp-type->rep-type expected-type))
	       (max-rep (elt +all-number-rep-types+
			     (max (position arg1-rep +all-number-rep-types+)
				  (position arg2-rep +all-number-rep-types+)
				  (position out-rep +all-number-rep-types+))
			     ))
	       (max-name (rep-type-name max-rep)))
	  (produce-inline-loc
	   (list arg1 arg2)
	   (list arg1-rep arg2-rep)
	   (list max-rep)
	   (format nil "(~@[(~A)~]#0)~A(~@[(~A)~]#1)"
		   (unless (eq arg1-rep max-rep) max-name)
		   non-consing
		   (unless (eq arg2-rep max-rep) max-name))
	   nil t))
	(produce-inline-loc (list arg1 arg2) '(:object :object) '(:object)
			    consing nil t))))
154
155

(defun inline-arith-unop (expected-type arg1 consing non-consing)
156
157
158
159
160
161
162
163
164
165
  (let ((arg1-type (inlined-arg-type arg1)))
    (if (and (policy-assume-right-type)
	     (c-number-type-p expected-type)
	     (c-number-type-p arg1-type))
	(produce-inline-loc (list arg1)
			    (list (lisp-type->rep-type arg1-type))
			    (list (lisp-type->rep-type expected-type))
			    non-consing nil t)
	(produce-inline-loc (list arg1) '(:object :object) '(:object)
			    consing nil t))))
166
167
168
169
170
171
172
173

(define-c-inliner + (return-type &rest arguments &aux arg1 arg2)
  (when (null arguments)
    (return '(fixnum-value 0)))
  (setf arg1 (pop arguments))
  (when (null arguments)
    (return (inlined-arg-loc arg1)))
  (loop for arg2 = (pop arguments)
174
     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
175
176
177
178
179
180
     do (if arguments
	    (setf arg1 (save-inline-loc result))
	    (return result))))

(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
181
    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
182
  (loop for arg2 = (pop arguments)
183
     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
184
185
186
187
188
189
190
191
192
193
194
     do (if arguments
	    (setf arg1 (save-inline-loc result))
	    (return result))))

(define-c-inliner * (return-type &rest arguments &aux arg1 arg2)
  (when (null arguments)
    (return '(fixnum-value 1)))
  (setf arg1 (pop arguments))
  (when (null arguments)
    (return (inlined-arg-loc arg1)))
  (loop for arg2 = (pop arguments)
195
     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
196
197
198
199
200
201
     do (if arguments
	    (setf arg1 (save-inline-loc result))
	    (return result))))

(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
202
    (return (inline-arith-unop return-type arg1
203
                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
204
  (loop for arg2 = (pop arguments)
205
     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
206
207
208
209
     do (if arguments
	    (setf arg1 (save-inline-loc result))
	    (return result))))

210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
;;;
;;; 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)
231
            (maximum-number-type t1 op2-type :only-real t)
232
233
234
235
236
          (values (list t1 t2) result))
        (values (list t1) t1))))

(def-type-propagator expt (fname base exponent)
  ;; Rules:
237
238
  ;;	(expt fixnum integer) -> integer
  ;;    (expt number-type integer) -> number-type
239
240
  ;;	(expt number-type1 number-type2) -> (max-float number-type1 number-type2)
  ;;
241
242
243
  (let ((exponent (ensure-real-type exponent)))
    (values (list base exponent)
	    (cond ((eql exponent 'integer)
244
245
246
		   (if (subtypep base 'fixnum)
		       'integer
		       base))
247
248
249
250
251
		  ((type>= '(real 0 *) base)
		   (let* ((exponent (ensure-nonrational-type exponent)))
		     (maximum-number-type exponent base)))
		  (t
		   'number)))))
252
253
254
255
256

(def-type-propagator abs (fname arg)
  (multiple-value-bind (output arg)
      (ensure-number-type arg)
    (values (list arg)
257
258
259
260
261
262
263
264
265
266
            (or (cdr (assoc output
                            '((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 *)))))
267
268
269
270
271
272
                output))))

(def-type-propagator sqrt (fname arg)
  (multiple-value-bind (output arg)
      (ensure-nonrational-type arg)
    (values (list arg)
273
            (if (type>= '(REAL 0 *) arg) output 'NUMBER))))
274
275

(def-type-propagator isqrt (fname arg)
276
277
278
279
  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
              '(integer 0 #.MOST-POSITIVE-FIXNUM))
      (values '((integer 0 *)) '(integer 0 *))))
280