cmpct.lsp 4.79 KB
Newer Older
jgarcia's avatar
jgarcia committed
1
2
;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
jjgarcia's avatar
jjgarcia committed
3
4
5
6
7
8
9
10
11
12
13
14
15
;;;; CMPCT --  Optimizer for several constant values

;;;;  Copyright (c) 2003, 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")

16
(defparameter +optimizable-constants+ '())
jjgarcia's avatar
jjgarcia committed
17

18
(defun c1constant-value (val &key always only-small-values)
jjgarcia's avatar
jjgarcia committed
19
  (cond
20
   ((let ((x (assoc val +optimizable-constants+)))
21
22
      (when x
       (pushnew "#include <float.h>" *clines-string-list*)
23
24
25
26
       (setf x (cdr x))
       (if (listp x)
           (c1expr x)
           x))))
jjgarcia's avatar
jjgarcia committed
27
28
29
30
31
32
33
   ((eq val nil) (c1nil))
   ((eq val t) (c1t))
   ((sys::fixnump val)
    (make-c1form* 'LOCATION :type 'FIXNUM :args (list 'FIXNUM-VALUE val)))
   ((characterp val)
    (make-c1form* 'LOCATION :type 'CHARACTER
		  :args (list 'CHARACTER-VALUE (char-code val))))
34
35
36
37
38
39
   ((typep val 'DOUBLE-FLOAT)
    (make-c1form* 'LOCATION :type 'DOUBLE-FLOAT
		  :args (list 'DOUBLE-FLOAT-VALUE val (add-object val))))
   ((typep val 'SINGLE-FLOAT)
    (make-c1form* 'LOCATION :type 'SINGLE-FLOAT
		  :args (list 'SINGLE-FLOAT-VALUE val (add-object val))))
40
41
42
   ((typep val 'LONG-FLOAT)
    (make-c1form* 'LOCATION :type 'LONG-FLOAT
		  :args (list 'LONG-FLOAT-VALUE val (add-object val))))
43
   (always
jjgarcia's avatar
jjgarcia committed
44
45
    (make-c1form* 'LOCATION :type (object-type val)
		  :args (list 'VV (add-object val))))
46
   (only-small-values nil)
jjgarcia's avatar
jjgarcia committed
47
48
49
50
   (t nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
51
;;; KNOWN OPTIMIZABLE CONSTANTS
jjgarcia's avatar
jjgarcia committed
52
53
54
55
56
;;;

(mapc
 #'(lambda (record)
     (let* ((name (first record))
57
58
59
60
61
62
63
	    (c-value (second record)))
       (push 
        (cond ((symbolp name)
               (let* ((value (symbol-value name))
                      (type (lisp-type->rep-type (type-of value))))
                 (cons value `(c-inline () () ,type ,c-value
                                        :one-liner t :side-effects nil))))
64
              ((floatp name)
65
66
67
68
69
70
71
72
73
74
               (let* ((value name)
                      (type (type-of value))
                      (loc-type (case type
                                  (single-float 'single-float-value)
                                  (double-float 'double-float-value)
                                  (long-float 'long-float-value)))
                      (location `(VV ,c-value)))
                (cons value (make-c1form* 'LOCATION :type type
                                          :args (list loc-type value location)))))
              (t
75
76
               (cons name (make-c1form* 'LOCATION :type (type-of name)
                                         :args `(VV ,c-value)))))
77
        +optimizable-constants+)))
78
 (reverse
79
 `((MOST-POSITIVE-SHORT-FLOAT "FLT_MAX")
jjgarcia's avatar
jjgarcia committed
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
   (MOST-POSITIVE-SINGLE-FLOAT "FLT_MAX")

   (MOST-NEGATIVE-SHORT-FLOAT "-FLT_MAX")
   (MOST-NEGATIVE-SINGLE-FLOAT "-FLT_MAX")

   (LEAST-POSITIVE-SHORT-FLOAT "FLT_MIN")
   (LEAST-POSITIVE-SINGLE-FLOAT "FLT_MIN")
   (LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT "FLT_MIN")
   (LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" FLT_MIN")

   (LEAST-NEGATIVE-SHORT-FLOAT "-FLT_MIN")
   (LEAST-NEGATIVE-SINGLE-FLOAT "-FLT_MIN")
   (LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT "-FLT_MIN")
   (LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT "-FLT_MIN")

   (MOST-POSITIVE-DOUBLE-FLOAT "DBL_MAX")
   (MOST-NEGATIVE-DOUBLE-FLOAT "-DBL_MAX")
   (LEAST-POSITIVE-DOUBLE-FLOAT "DBL_MIN")
   (LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT "DBL_MIN")
   (LEAST-NEGATIVE-DOUBLE-FLOAT "-DBL_MIN")
   (LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT "-DBL_MIN")
101

102
103
104
105
   ;; Order is important: on platforms where 0.0 and -0.0 are the same
   ;; the last one is prioritized.
   (#.(coerce 0 'single-float) "cl_core.singlefloat_zero")
   (#.(coerce 0 'double-float) "cl_core.doublefloat_zero")
106
107
   (#.(coerce -0.0 'single-float) "cl_core.singlefloat_minus_zero")
   (#.(coerce -0.0 'double-float) "cl_core.doublefloat_minus_zero")
108

109
110
   (#.(si::standard-readtable) "cl_core.standard_readtable")

111
112
113
114
115
116
117
   (#.(find-package :cl) "cl_core.lisp_package")
   (#.(find-package :cl-user) "cl_core.user_package")
   (#.(find-package :keyword) "cl_core.keyword_package")
   (#.(find-package :clos) "cl_core.clos_package")
   #+threads
   (#.(find-package :mp) "cl_core.mp_package")

118
   #+long-float
119
   ,@'(
120
121
122
123
124
125
    (MOST-POSITIVE-LONG-FLOAT "LDBL_MAX")
    (MOST-NEGATIVE-LONG-FLOAT "-LDBL_MAX")
    (LEAST-POSITIVE-LONG-FLOAT "LDBL_MIN")
    (LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" LDBL_MIN")
    (LEAST-NEGATIVE-LONG-FLOAT "-LDBL_MIN")
    (LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT "-LDBL_MIN")
126
127
    (#.(coerce -0.0 'long-float) "cl_core.longfloat_minus_zero")
    (#.(coerce 0 'long-float) "cl_core.longfloat_zero")
128
    )
129
   )))