cmpnum.lsp 12.3 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 (t1 t2 &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
98
        (output nil)
        (default (if only-real 'REAL 'NUMBER))
        (types-list (if only-real
99
                        '(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
100
                          DOUBLE-FLOAT LONG-FLOAT FLOAT REAL
101
                          NUMBER)
102
                        '(FIXNUM INTEGER RATIONAL SINGLE-FLOAT
103
                          DOUBLE-FLOAT LONG-FLOAT FLOAT REAL))))
104
    (dolist (i types-list)
105
106
107
      (when (and (null t1-eq) (type>= i t1))
        (if (equalp t1 t2)
            (setf t2-eq i))
108
        (setf t1-eq i output i))
109
      (when (and (null t2-eq) (type>= i t2))
110
111
112
113
114
115
        (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))))
116

117
118
(defun ensure-number-type (general-type)
  (maximum-number-type general-type general-type))
119

120
(defun ensure-nonrational-type (general-type)
121
  (maximum-number-type general-type 'single-float))
122

123
(defun ensure-real-type (general-type)
124
  (maximum-number-type general-type 'integer :only-real t))
125

126
127
128
129
130
131
132
133
134
135
136
137
138
(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)
139
              (maximum-number-type result-type op2-type :integer-result integer-result))
140
141
142
143
            (setf arg-types (cons op2-type arg-types)))
       finally (return (values (nreverse arg-types) result-type)))))

(def-type-propagator * (fname op1 &rest others)
144
  (arithmetic-propagator op1 others 'integer))
145

146
147
(copy-type-propagator '* '(+ -))

148
149
(def-type-propagator / (fname op1 &rest others)
  (arithmetic-propagator op1 others 'rational))
150

151
152
(defun most-generic-number-rep-type (r1 r2)
  (let* ((r1 (rep-type-record r1))
Daniel Kochmański's avatar
Daniel Kochmański committed
153
         (r2 (rep-type-record r2)))
154
    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
Daniel Kochmański's avatar
Daniel Kochmański committed
155
156
                       r2
                       r1))))
157

158
159
(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
160
        (arg2-type (inlined-arg-type arg2)))
161
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
             (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))))
187
188

(defun inline-arith-unop (expected-type arg1 consing non-consing)
189
190
  (let ((arg1-type (inlined-arg-type arg1)))
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
191
192
193
194
195
196
197
198
             (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))))
199
200
201
202
203
204
205
206

(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)
207
     for result = (inline-binop return-type arg1 arg2 "ecl_plus(#0,#1)" #\+)
208
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
209
210
            (setf arg1 (save-inline-loc result))
            (return result))))
211
212
213

(define-c-inliner - (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
214
    (return (inline-arith-unop return-type arg1 "ecl_negate(#0)" "-(#0)")))
215
  (loop for arg2 = (pop arguments)
216
     for result = (inline-binop return-type arg1 arg2 "ecl_minus(#0,#1)" #\-)
217
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
218
219
            (setf arg1 (save-inline-loc result))
            (return result))))
220
221
222
223
224
225
226
227

(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)
228
     for result = (inline-binop return-type arg1 arg2 "ecl_times(#0,#1)" #\*)
229
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
230
231
            (setf arg1 (save-inline-loc result))
            (return result))))
232
233
234

(define-c-inliner / (return-type arg1 &rest arguments &aux arg2)
  (when (null arguments)
235
    (return (inline-arith-unop return-type arg1
236
                               "ecl_divide(ecl_make_fixnum(1),(#0))" "1/(#0)")))
237
  (loop for arg2 = (pop arguments)
238
     for result = (inline-binop return-type arg1 arg2 "ecl_divide(#0,#1)" #\/)
239
     do (if arguments
Daniel Kochmański's avatar
Daniel Kochmański committed
240
241
            (setf arg1 (save-inline-loc result))
            (return result))))
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
;;;
;;; 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)
264
            (maximum-number-type t1 op2-type :only-real t)
265
266
267
268
269
          (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
270
  ;;    (expt fixnum integer) -> integer
271
  ;;    (expt number-type integer) -> number-type
Daniel Kochmański's avatar
Daniel Kochmański committed
272
  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
273
  ;;
274
275
  (let ((exponent (ensure-real-type exponent)))
    (values (list base exponent)
Daniel Kochmański's avatar
Daniel Kochmański committed
276
277
278
279
280
281
282
283
284
            (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)))))
285
286
287
288
289

(def-type-propagator abs (fname arg)
  (multiple-value-bind (output arg)
      (ensure-number-type arg)
    (values (list arg)
290
291
292
293
294
295
296
297
298
299
            (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 *)))))
300
301
302
303
304
305
                output))))

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

(def-type-propagator isqrt (fname arg)
309
310
311
312
  (if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
      (values '((integer 0 #.MOST-POSITIVE-FIXNUM))
              '(integer 0 #.MOST-POSITIVE-FIXNUM))
      (values '((integer 0 *)) '(integer 0 *))))
313