cmpnum.lsp 11.2 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
18
;;;; 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)
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
  (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"
43
44
                      :format-arguments (list operator (or whole
                                                           (list* operator args)))))))))
45
46
47
48
49
50
51
52
53
54
55
56
57

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

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

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

91
92
(defun ensure-number-type (general-type)
  (maximum-number-type general-type general-type))
93

94
(defun ensure-nonrational-type (general-type)
95
  (maximum-number-type general-type 'single-float))
96

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

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

(def-type-propagator * (fname op1 &rest others)
118
  (arithmetic-propagator op1 others 'integer))
119

120
121
(copy-type-propagator '* '(+ -))

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

125
126
(defun most-generic-number-rep-type (r1 r2)
  (let* ((r1 (rep-type-record r1))
Daniel Kochmański's avatar
Daniel Kochmański committed
127
         (r2 (rep-type-record r2)))
128
    (rep-type-name (if (< (rep-type-index r1) (rep-type-index r2))
Daniel Kochmański's avatar
Daniel Kochmański committed
129
130
                       r2
                       r1))))
131

132
133
(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
134
        (arg2-type (inlined-arg-type arg2)))
135
    (if (and (policy-assume-right-type)
Daniel Kochmański's avatar
Daniel Kochmański committed
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
             (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))))
161
162

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

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

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

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

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

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
;;;
;;; 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)
238
            (maximum-number-type t1 op2-type :only-real t)
239
240
241
242
243
          (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
244
  ;;    (expt fixnum integer) -> integer
245
  ;;    (expt number-type integer) -> number-type
Daniel Kochmański's avatar
Daniel Kochmański committed
246
  ;;    (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
247
  ;;
248
249
  (let ((exponent (ensure-real-type exponent)))
    (values (list base exponent)
Daniel Kochmański's avatar
Daniel Kochmański committed
250
251
252
253
254
255
256
257
258
            (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)))))
259
260
261
262
263

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

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

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