1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
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
159
160
161
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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
|
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 0b09cd7d225..8fdafe18c50 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3093,16 +3093,13 @@ cl-defstruct
(cons 'and (cdddr pred-form))
`(,predicate cl-x))))
(when pred-form
- (push `(eval-and-compile
- ;; Define the predicate to be effective at compile time
- ;; as native comp relies on `cl-typep' that relies on
- ;; predicates to be defined as they are registered in
- ;; cl-deftype-satisfies.
- (,defsym ,predicate (cl-x)
+ (push `(,defsym ,predicate (cl-x)
(declare (side-effect-free error-free) (pure t))
,(if (eq (car pred-form) 'and)
(append pred-form '(t))
`(and ,pred-form t)))
+ forms)
+ (push `(eval-and-compile
(define-symbol-prop ',name 'cl-deftype-satisfies ',predicate))
forms))
(let ((pos 0) (descp descs))
@@ -3252,7 +3249,6 @@ cl-defstruct
;;; Add cl-struct support to pcase
-;;In use by comp.el
(defun cl--struct-all-parents (class)
(when (cl--struct-class-p class)
(let ((res ())
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index f410270d340..5235be52996 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -113,7 +113,6 @@ cl-struct-cl-structure-object-tags
(record 'cl-slot-descriptor
name initform type props)))
-;; In use by comp.el
(defun cl--struct-get-class (name)
(or (if (not (symbolp name)) name)
(cl--find-class name)
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index e9132552506..d4200c16c19 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -86,35 +86,7 @@ comp-cstr-f
(ret nil :type (or comp-cstr comp-cstr-f)
:documentation "Returned value."))
-(defun comp--cl-class-hierarchy (x)
- "Given a class name `x' return its hierarchy."
- `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents
- (cl--struct-get-class x)))
- atom
- t))
-
-(defun comp--all-classes ()
- "Return all non built-in type names currently defined."
- (let (res)
- (mapatoms (lambda (x)
- (when (cl-find-class x)
- (push x res)))
- obarray)
- res))
-
(cl-defstruct comp-cstr-ctxt
- (typeof-types (append comp--typeof-builtin-types
- (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
- :type list
- :documentation "Type hierarchy.")
- (pred-type-h (cl-loop with h = (make-hash-table :test #'eq)
- for class-name in (comp--all-classes)
- for pred = (get class-name 'cl-deftype-satisfies)
- when pred
- do (puthash pred class-name h)
- finally return h)
- :type hash-table
- :documentation "Hash pred -> type.")
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`comp-union-typesets'.")
@@ -258,7 +230,7 @@ comp-supertypes
(cl-loop
named outer
with found = nil
- for l in (comp-cstr-ctxt-typeof-types comp-ctxt)
+ for l in comp--typeof-builtin-types
do (cl-loop
for x in l
for i from (length l) downto 0
@@ -301,7 +273,7 @@ comp-union-typesets
(cl-loop
with types = (apply #'append typesets)
with res = '()
- for lane in (comp-cstr-ctxt-typeof-types comp-ctxt)
+ for lane in comp--typeof-builtin-types
do (cl-loop
with last = nil
for x in lane
@@ -895,23 +867,6 @@ comp-cstr-cons-p
(null (neg cstr))
(equal (typeset cstr) '(cons)))))
-;; Move to comp.el?
-(defsubst comp-cstr-cl-tag-p (cstr)
- "Return non-nil if CSTR is a CL tag."
- (with-comp-cstr-accessors
- (and (null (range cstr))
- (null (neg cstr))
- (null (typeset cstr))
- (length= (valset cstr) 1)
- (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags")
- (symbol-name (car (valset cstr)))))))
-
-(defsubst comp-cstr-cl-tag (cstr)
- "If CSTR is a CL tag return its tag name."
- (with-comp-cstr-accessors
- (and (comp-cstr-cl-tag-p cstr)
- (intern (match-string 1 (symbol-name (car (valset cstr))))))))
-
(defun comp-cstr-= (dst op1 op2)
"Constraint OP1 being = OP2 setting the result into DST."
(with-comp-cstr-accessors
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 8e59c06d40e..2e07b0b0e60 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -641,14 +641,11 @@ comp-known-predicates-h
(defun comp-known-predicate-p (predicate)
"Return t if PREDICATE is known."
- (when (or (gethash predicate comp-known-predicates-h)
- (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
- t))
+ (when (gethash predicate comp-known-predicates-h) t))
(defun comp-pred-to-cstr (predicate)
"Given PREDICATE, return the corresponding constraint."
- (or (gethash predicate comp-known-predicates-h)
- (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
+ (gethash predicate comp-known-predicates-h))
(defconst comp-symbol-values-optimizable '(most-positive-fixnum
most-negative-fixnum)
@@ -1543,7 +1540,7 @@ comp-callref
for sp from stack-off
collect (comp-slot-n sp))))
-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
+(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
"`comp-mvar' initializer."
(let ((mvar (make--comp-mvar :slot slot)))
(when const-vld
@@ -1551,8 +1548,6 @@ make-comp-mvar
(setf (comp-cstr-imm mvar) constant))
(when type
(setf (comp-mvar-typeset mvar) (list type)))
- (when neg
- (setf (comp-mvar-neg mvar) t))
mvar))
(defun comp-new-frame (size vsize &optional ssa)
@@ -2548,19 +2543,6 @@ comp-add-cond-cstrs
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
- (`((set ,(and (pred comp-mvar-p) mvar-tested-copy)
- ,(and (pred comp-mvar-p) mvar-tested))
- (set ,(and (pred comp-mvar-p) mvar-1)
- (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy)))
- (set ,(and (pred comp-mvar-p) mvar-2)
- (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag)))
- (set ,(and (pred comp-mvar-p) mvar-3)
- (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2)))
- (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2))
- (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag)))
- (comp-block-insns (comp-add-cond-cstrs-target-block b bb2)))
- (push `(assume ,mvar-tested ,(make-comp-mvar :type (comp-cstr-cl-tag mvar-tag) :neg t))
- (comp-block-insns (comp-add-cond-cstrs-target-block b bb1))))
(`((set ,(and (pred comp-mvar-p) cmp-res)
(,(pred comp-call-op-p)
,(and (or (pred comp-equality-fun-p)
@@ -3216,11 +3198,7 @@ comp-fwprop-call
(+ (comp-cstr-add lval args))
(- (comp-cstr-sub lval args))
(1+ (comp-cstr-add lval `(,(car args) ,comp-cstr-one)))
- (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one)))
- (record (when (comp-cstr-imm-vld-p (car args))
- (comp-cstr-shallow-copy lval
- (comp-type-spec-to-cstr
- (comp-cstr-imm (car args)))))))))
+ (1- (comp-cstr-sub lval `(,(car args) ,comp-cstr-one))))))
(defun comp-fwprop-insn (insn)
"Propagate within INSN."
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 532d2ca176d..1cc70348267 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -103,7 +103,7 @@
;; During bootstrapping the byte-compiler is run interpreted
;; when compiling itself, which uses a lot more stack
;; than usual.
- (setq max-lisp-eval-depth (max max-lisp-eval-depth 3400))))
+ (setq max-lisp-eval-depth 2200)))
(if (eq t purify-flag)
;; Hash consing saved around 11% of pure space in my tests.
diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el
index d8c72c1a920..73da7182a54 100644
--- a/test/src/comp-resources/comp-test-funcs.el
+++ b/test/src/comp-resources/comp-test-funcs.el
@@ -23,8 +23,6 @@
;;; Code:
-(require 'cl-lib)
-
(defvar comp-tests-var1 3)
(defun comp-tests-varref-f ()
@@ -532,12 +530,6 @@ comp-test-62537-2-f
(comp-test-62537-1-f))
t)
-(cl-defstruct comp-test-struct)
-
-(defun comp-test-63674-1-f (x)
- (or
- (if (comp-test-struct-p pkg) x)
- t))
;;;;;;;;;;;;;;;;;;;;
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 673a9342f1f..4682cac450e 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -875,8 +875,6 @@ comp-tests-check-ret-type-spec
ret-type))))
(cl-eval-when (compile eval load)
- (cl-defstruct comp-foo a b)
- (cl-defstruct (comp-bar (:include comp-foo)) c)
(defconst comp-tests-type-spec-tests
;; Why we quote everything here, you ask? So that values of
;; `most-positive-fixnum' and `most-negative-fixnum', which can be
@@ -1406,39 +1404,7 @@ comp-tests-check-ret-type-spec
(if (eq x 0)
(error "")
(1+ x)))
- 'number)
-
- ;; 75
- ((defun comp-tests-ret-type-spec-f ()
- (make-comp-foo))
- 'comp-foo)
-
- ;; 76
- ((defun comp-tests-ret-type-spec-f ()
- (make-comp-bar))
- 'comp-bar)
-
- ;; 77
- ((defun comp-tests-ret-type-spec-f (x)
- (setf (comp-foo-a x) 2)
- x)
- 'comp-foo)
-
- ;; 78
- ((defun comp-tests-ret-type-spec-f (x)
- (if x
- (if (> x 11)
- x
- (make-comp-foo))
- (make-comp-bar)))
- '(or comp-foo float (integer 12 *)))
-
- ;; 79
- ((defun comp-tests-ret-type-spec-f (x)
- (if (comp-foo-p x)
- x
- (error "")))
- 'comp-foo)))
+ 'number)))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
--
2.40.1
|