cmpnum.lsp 11.1 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
(defun most-generic-number-rep-type (r1 r2)
  (let* ((r1 (rep-type-record r1))
Daniel Kochmański's avatar
Daniel Kochmański committed
125
         (r2 (rep-type-record r2)))
126
    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
Daniel Kochmański's avatar
Daniel Kochmański committed
127
128
                       r2
                       r1))))
129

130
131
(defun inline-binop (expected-type arg1 arg2 consing non-consing)
  (let ((arg1-type (inlined-arg-type arg1))
Daniel Kochmański's avatar
Daniel Kochmański committed
132
        (arg2-type (inlined-arg-type arg2)))
133
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
             (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 (most-generic-number-rep-type
                         (most-generic-number-rep-type
                          arg1-rep arg2-rep) out-rep))
               (max-name (rep-type->c-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))))
159
160

(defun inline-arith-unop (expected-type arg1 consing non-consing)
161
162
  (let ((arg1-type (inlined-arg-type arg1)))
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
163
164
165
166
167
168
169
170
             (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))))
171
172
173
174
175
176
177
178

(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)
179
     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
180
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
181
182
            (setf arg1 (save-inline-loc result))
            (return result))))
183
184
185

(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
186
    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
187
  (loop for arg2 = (pop arguments)
188
     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
189
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
190
191
            (setf arg1 (save-inline-loc result))
            (return result))))
192
193
194
195
196
197
198
199

(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)
200
     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
201
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
202
203
            (setf arg1 (save-inline-loc result))
            (return result))))
204
205
206

(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
207
    (return (inline-arith-unop return-type arg1
208
                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
209
  (loop for arg2 = (pop arguments)
210
     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
211
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
212
213
            (setf arg1 (save-inline-loc result))
            (return result))))
214

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

(def-type-propagator expt (fname base exponent)
  ;; Rules:
Daniel Kochmański's avatar
Daniel Kochmański committed
242
  ;;    (expt fixnum integer) -> integer
243
  ;;    (expt number-type integer) -> number-type
Daniel Kochmański's avatar
Daniel Kochmański committed
244
  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
245
  ;;
246
247
  (let ((exponent (ensure-real-type exponent)))
    (values (list base exponent)
Daniel Kochmański's avatar
Daniel Kochmański committed
248
249
250
251
252
253
254
255
256
            (cond ((eql exponent 'integer)
                   (if (subtypep base 'fixnum)
                       'integer
                       base))
                  ((type>= '(real 0 *) base)
                   (let* ((exponent (ensure-nonrational-type exponent)))
                     (maximum-number-type exponent base)))
                  (t
                   'number)))))
257
258
259
260
261

(def-type-propagator abs (fname arg)
  (multiple-value-bind (output arg)
      (ensure-number-type arg)
    (values (list arg)
262
263
264
265
266
267
268
269
270
271
            (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 *)))))
272
273
274
275
276
277
                output))))

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

(def-type-propagator isqrt (fname arg)
281
282
283
284
  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
              '(integer 0 #.MOST-POSITIVE-FIXNUM))
      (values '((integer 0 *)) '(integer 0 *))))
285