cmpnum.lsp 12.8 KB
Newer Older
1
2
3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

jgarcia's avatar
jgarcia committed
4
;;;;
5
6
7
8
9
10
11
12
13
14
15
16
17
;;;; 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")

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
;;----------------------------------------------------------------------
;; We transform BOOLE into the individual operations, which have
;; inliners
;;

(define-compiler-macro boole (&whole form op-code op1 op2)
  (or (and (constantp op-code *cmp-env*)
           (case (ext:constant-form-value op-code *cmp-env*)
             (#. boole-clr `(progn ,op1 ,op2 0))
             (#. boole-set `(progn ,op1 ,op2 -1))
             (#. boole-1 `(prog1 ,op1 ,op2))
             (#. boole-2 `(progn ,op1 ,op2))
             (#. boole-c1 `(prog1 (lognot ,op1) ,op2))
             (#. boole-c2 `(progn ,op1 (lognot ,op2)))
             (#. boole-and `(logand ,op1 ,op2))
             (#. boole-ior `(logior ,op1 ,op2))
             (#. boole-xor `(logxor ,op1 ,op2))
             (#. boole-eqv `(logeqv ,op1 ,op2))
             (#. boole-nand `(lognand ,op1 ,op2))
             (#. boole-nor `(lognor ,op1 ,op2))
             (#. boole-andc1 `(logandc1 ,op1 ,op2))
             (#. boole-andc2 `(logandc2 ,op1 ,op2))
             (#. boole-orc1 `(logorc1 ,op1 ,op2))
             (#. boole-orc2 `(logorc2 ,op1 ,op2))))
      form))

44
(defun simplify-arithmetic (operator args whole)
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
  (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"
69
70
                      :format-arguments (list operator (or whole
                                                           (list* operator args)))))))))
71
72
73
74
75
76
77
78
79
80
81
82
83

(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))

84
85
86
87
88
;;;
;;; The following are type propagators for arithmetic operations. Note
;;; that some of they have become binary operators.
;;;

89
(defun maximum-number-type (type1 type2 &key only-real integer-result)
90
91
92
93
  ;; 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.
94
95
  (let ((t1-eq nil)
        (t2-eq nil)
96
97
        (t1 type1)
        (t2 type2)
98
        (output nil)
99
100
        (complex-t1 nil)
        (complex-t2 nil)
101
        (default (if only-real 'REAL 'NUMBER))
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
        (number-types #(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
                        DOUBLE-FLOAT LONG-FLOAT FLOAT REAL)))
    (when (and (consp t1) (eq (first t1) 'COMPLEX))
      (setf t1 (second t1) complex-t1 t))
    (when (and (consp t2) (eq (first t2) 'COMPLEX))
      (setf t2 (second t2) complex-t2 t))
    (when (and only-real (or complex-t1 complex-t2))
      (return-from maximum-number-type (values default default default)))
    (loop for i across number-types
          do (when (and (null t1-eq) (type>= i t1))
               (when (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)))
117
118
    (unless (and t1-eq t2-eq output)
      (setf output default))
119
    (when (and integer-result (or (eq output 'FIXNUM) (eq output 'INTEGER)))
120
      (setf output integer-result))
121
122
123
    (when (and (or complex-t1 complex-t2) (not (eq output 'NUMBER)))
      (setf output (if (eq output 'REAL) 'COMPLEX `(COMPLEX ,output))))
    (values output (if t1-eq type1 default) (if t2-eq type2 default))))
124

125
126
(defun ensure-number-type (general-type &key integer-result)
  (maximum-number-type general-type general-type :integer-result integer-result))
127

128
(defun ensure-nonrational-type (general-type)
129
  (maximum-number-type general-type 'single-float))
130

131
(defun ensure-real-type (general-type)
132
  (maximum-number-type general-type 'integer :only-real t))
133

134
135
136
137
138
139
140
(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)
141
      (ensure-number-type op1-type :integer-result integer-result)
142
143
144
145
146
    (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)
147
              (maximum-number-type result-type op2-type :integer-result integer-result))
148
149
150
151
            (setf arg-types (cons op2-type arg-types)))
       finally (return (values (nreverse arg-types) result-type)))))

(def-type-propagator * (fname op1 &rest others)
152
  (arithmetic-propagator op1 others 'integer))
153

154
155
(copy-type-propagator '* '(+ -))

156
157
(def-type-propagator / (fname op1 &rest others)
  (arithmetic-propagator op1 others 'rational))
158

159
160
(defun most-generic-number-rep-type (r1 r2)
  (let* ((r1 (rep-type-record r1))
Daniel Kochmański's avatar
Daniel Kochmański committed
161
         (r2 (rep-type-record r2)))
162
    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
Daniel Kochmański's avatar
Daniel Kochmański committed
163
164
                       r2
                       r1))))
165

166
167
(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
168
        (arg2-type (inlined-arg-type arg2)))
169
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
             (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))))
195
196

(defun inline-arith-unop (expected-type arg1 consing non-consing)
197
198
  (let ((arg1-type (inlined-arg-type arg1)))
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
199
200
201
202
203
204
205
206
             (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))))
207
208
209
210
211
212
213
214

(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)
215
     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
216
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
217
218
            (setf arg1 (save-inline-loc result))
            (return result))))
219
220
221

(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
222
    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
223
  (loop for arg2 = (pop arguments)
224
     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
225
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
226
227
            (setf arg1 (save-inline-loc result))
            (return result))))
228
229
230
231
232
233
234
235

(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)
236
     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
237
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
238
239
            (setf arg1 (save-inline-loc result))
            (return result))))
240
241
242

(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
243
    (return (inline-arith-unop return-type arg1
244
                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
245
  (loop for arg2 = (pop arguments)
246
     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
247
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
248
249
            (setf arg1 (save-inline-loc result))
            (return result))))
250

251
252
253
254
255
256
257
258
259
260
261
262
263
264
;;;
;;; 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)
265
    (declare (ignore output-type))
266
267
268
269
270
    (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)
271
    (declare (ignore float-t1))
272
273
    (if op2-p
        (multiple-value-bind (result t1 t2)
274
            (maximum-number-type t1 op2-type :only-real t)
275
276
277
278
279
          (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
280
  ;;    (expt fixnum integer) -> integer
281
  ;;    (expt number-type integer) -> number-type
Daniel Kochmański's avatar
Daniel Kochmański committed
282
  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
283
  ;;
284
285
  (let ((exponent (ensure-real-type exponent)))
    (values (list base exponent)
Daniel Kochmański's avatar
Daniel Kochmański committed
286
287
288
289
290
291
292
293
294
            (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)))))
295
296
297
298
299

(def-type-propagator abs (fname arg)
  (multiple-value-bind (output arg)
      (ensure-number-type arg)
    (values (list arg)
300
301
302
303
304
305
306
307
308
309
            (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 *)))))
310
311
312
313
314
315
                output))))

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

(def-type-propagator isqrt (fname arg)
319
320
321
322
  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
              '(integer 0 #.MOST-POSITIVE-FIXNUM))
      (values '((integer 0 *)) '(integer 0 *))))
323