1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | (in-package "CCL") |
---|
19 | |
---|
20 | (require 'systems) |
---|
21 | |
---|
22 | (defparameter *sysdef-modules* |
---|
23 | '(systems compile-ccl)) |
---|
24 | |
---|
25 | (defparameter *level-1-modules* |
---|
26 | '(level-1 |
---|
27 | l1-cl-package |
---|
28 | l1-boot-1 l1-boot-2 l1-boot-3 |
---|
29 | l1-utils l1-init l1-symhash l1-numbers l1-aprims |
---|
30 | l1-sort l1-dcode l1-clos-boot l1-clos |
---|
31 | l1-unicode l1-streams l1-files l1-io |
---|
32 | l1-format l1-readloop l1-reader |
---|
33 | l1-sysio l1-pathnames l1-events |
---|
34 | l1-boot-lds l1-readloop-lds |
---|
35 | l1-lisp-threads l1-application l1-processes |
---|
36 | l1-typesys sysutils l1-error-system |
---|
37 | l1-error-signal version l1-callbacks |
---|
38 | l1-sockets linux-files |
---|
39 | )) |
---|
40 | |
---|
41 | (defparameter *compiler-modules* |
---|
42 | '(nx optimizers dll-node arch vreg vinsn |
---|
43 | reg subprims backend nx2)) |
---|
44 | |
---|
45 | |
---|
46 | (defparameter *ppc-compiler-modules* |
---|
47 | '(ppc32-arch |
---|
48 | ppc64-arch |
---|
49 | ppc-arch |
---|
50 | ppcenv |
---|
51 | ppc-asm |
---|
52 | risc-lap |
---|
53 | ppc-lap |
---|
54 | ppc-backend |
---|
55 | )) |
---|
56 | |
---|
57 | (defparameter *x86-compiler-modules* |
---|
58 | '(x8632-arch |
---|
59 | x8664-arch |
---|
60 | x86-arch |
---|
61 | x8632env |
---|
62 | x8664env |
---|
63 | x86-asm |
---|
64 | x86-lap |
---|
65 | x86-backend |
---|
66 | )) |
---|
67 | |
---|
68 | (defparameter *ppc32-compiler-backend-modules* |
---|
69 | '(ppc32-backend ppc32-vinsns)) |
---|
70 | |
---|
71 | (defparameter *ppc64-compiler-backend-modules* |
---|
72 | '(ppc64-backend ppc64-vinsns)) |
---|
73 | |
---|
74 | |
---|
75 | (defparameter *ppc-compiler-backend-modules* |
---|
76 | '(ppc2)) |
---|
77 | |
---|
78 | |
---|
79 | (defparameter *x8632-compiler-backend-modules* |
---|
80 | '(x8632-backend x8632-vinsns)) |
---|
81 | |
---|
82 | (defparameter *x8664-compiler-backend-modules* |
---|
83 | '(x8664-backend x8664-vinsns)) |
---|
84 | |
---|
85 | (defparameter *x86-compiler-backend-modules* |
---|
86 | '(x862)) |
---|
87 | |
---|
88 | |
---|
89 | |
---|
90 | |
---|
91 | (defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image )) |
---|
92 | (defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image )) |
---|
93 | (defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image )) |
---|
94 | |
---|
95 | |
---|
96 | ;;; Not too OS-specific. |
---|
97 | (defparameter *ppc-xdev-modules* '(ppc-lapmacros )) |
---|
98 | (defparameter *x86-xdev-modules* '(x86-lapmacros )) |
---|
99 | |
---|
100 | (defun target-xdev-modules (&optional (target |
---|
101 | (backend-target-arch-name |
---|
102 | *host-backend*))) |
---|
103 | (case target |
---|
104 | ((:ppc32 :ppc64) *ppc-xdev-modules*) |
---|
105 | ((:x8632 :x8664) *x86-xdev-modules*))) |
---|
106 | |
---|
107 | (defun target-xload-modules (&optional (target |
---|
108 | (backend-target-arch-name *host-backend*))) |
---|
109 | (case target |
---|
110 | ((:ppc32 :ppc64) *ppc-xload-modules*) |
---|
111 | (:x8632 *x8632-xload-modules*) |
---|
112 | (:x8664 *x8664-xload-modules*))) |
---|
113 | |
---|
114 | |
---|
115 | |
---|
116 | |
---|
117 | |
---|
118 | |
---|
119 | (defparameter *env-modules* |
---|
120 | '(hash backquote lispequ level-2 macros |
---|
121 | defstruct-macros lists chars setf setf-runtime |
---|
122 | defstruct defstruct-lds |
---|
123 | foreign-types |
---|
124 | db-io |
---|
125 | nfcomp |
---|
126 | )) |
---|
127 | |
---|
128 | (defun target-env-modules (&optional (target |
---|
129 | (backend-name *host-backend*))) |
---|
130 | (append *env-modules* |
---|
131 | (list |
---|
132 | (ecase target |
---|
133 | (:linuxppc32 'ffi-linuxppc32) |
---|
134 | (:darwinppc32 'ffi-darwinppc32) |
---|
135 | (:darwinppc64 'ffi-darwinppc64) |
---|
136 | (:linuxppc64 'ffi-linuxppc64) |
---|
137 | (:darwinx8632 'ffi-darwinx8632) |
---|
138 | (:linuxx8664 'ffi-linuxx8664) |
---|
139 | (:darwinx8664 'ffi-darwinx8664) |
---|
140 | (:freebsdx8664 'ffi-freebsdx8664) |
---|
141 | (:solarisx8664 'ffi-solarisx8664) |
---|
142 | (:win64 'ffi-win64) |
---|
143 | (:linuxx8632 'ffi-linuxx8632) |
---|
144 | (:win32 'ffi-win32) |
---|
145 | (:solarisx8632 'ffi-solarisx8632) |
---|
146 | (:freebsdx8632 'ffi-freebsdx8632))))) |
---|
147 | |
---|
148 | |
---|
149 | (defun target-compiler-modules (&optional (target |
---|
150 | (backend-target-arch-name |
---|
151 | *host-backend*))) |
---|
152 | (case target |
---|
153 | (:ppc32 (append *ppc-compiler-modules* |
---|
154 | *ppc32-compiler-backend-modules* |
---|
155 | *ppc-compiler-backend-modules*)) |
---|
156 | (:ppc64 (append *ppc-compiler-modules* |
---|
157 | *ppc64-compiler-backend-modules* |
---|
158 | *ppc-compiler-backend-modules*)) |
---|
159 | (:x8632 (append *x86-compiler-modules* |
---|
160 | *x8632-compiler-backend-modules* |
---|
161 | *x86-compiler-backend-modules*)) |
---|
162 | (:x8664 (append *x86-compiler-modules* |
---|
163 | *x8664-compiler-backend-modules* |
---|
164 | *x86-compiler-backend-modules*)))) |
---|
165 | |
---|
166 | (defparameter *other-lib-modules* |
---|
167 | '(streams pathnames backtrace |
---|
168 | apropos |
---|
169 | numbers |
---|
170 | dumplisp source-files)) |
---|
171 | |
---|
172 | (defun target-other-lib-modules (&optional (target |
---|
173 | (backend-target-arch-name |
---|
174 | *host-backend*))) |
---|
175 | (append *other-lib-modules* |
---|
176 | (case target |
---|
177 | ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble)) |
---|
178 | ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))))) |
---|
179 | |
---|
180 | |
---|
181 | (defun target-lib-modules (&optional (backend-name |
---|
182 | (backend-name *host-backend*))) |
---|
183 | (let* ((backend (or (find-backend backend-name) *host-backend*)) |
---|
184 | (arch-name (backend-target-arch-name backend))) |
---|
185 | (append (target-env-modules backend-name) (target-other-lib-modules arch-name)))) |
---|
186 | |
---|
187 | |
---|
188 | (defparameter *code-modules* |
---|
189 | '(encapsulate |
---|
190 | read misc arrays-fry |
---|
191 | sequences sort |
---|
192 | method-combination |
---|
193 | case-error pprint |
---|
194 | format time |
---|
195 | ; eval step |
---|
196 | backtrace-lds ccl-export-syms prepare-mcl-environment)) |
---|
197 | |
---|
198 | |
---|
199 | |
---|
200 | (defparameter *aux-modules* |
---|
201 | '(number-macros number-case-macro |
---|
202 | loop |
---|
203 | runtime |
---|
204 | mcl-compat |
---|
205 | arglist |
---|
206 | edit-callers |
---|
207 | describe |
---|
208 | cover |
---|
209 | leaks |
---|
210 | core-files |
---|
211 | dominance |
---|
212 | asdf |
---|
213 | defsystem |
---|
214 | jp-encode |
---|
215 | )) |
---|
216 | |
---|
217 | |
---|
218 | |
---|
219 | |
---|
220 | |
---|
221 | |
---|
222 | |
---|
223 | (defun target-level-1-modules (&optional (target (backend-name *host-backend*))) |
---|
224 | (append *level-1-modules* |
---|
225 | (case target |
---|
226 | ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64) |
---|
227 | '(ppc-error-signal ppc-trap-support |
---|
228 | ppc-threads-utils ppc-callback-support)) |
---|
229 | ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 |
---|
230 | :darwinx8632 :win64 :linuxx8632 :win32 :solarisx8632 |
---|
231 | :freebsdx8632) |
---|
232 | '(x86-error-signal x86-trap-support |
---|
233 | x86-threads-utils x86-callback-support))))) |
---|
234 | |
---|
235 | |
---|
236 | ;;; Needed to cross-dump an image |
---|
237 | |
---|
238 | |
---|
239 | (unless (fboundp 'xload-level-0) |
---|
240 | (%fhave 'xload-level-0 |
---|
241 | #'(lambda (&rest rest) |
---|
242 | (in-development-mode |
---|
243 | (require-modules (target-xload-modules))) |
---|
244 | (apply 'xload-level-0 rest)))) |
---|
245 | |
---|
246 | (defun find-module (module &optional (target (backend-name *host-backend*)) &aux data fasl sources) |
---|
247 | (if (setq data (assoc module *ccl-system*)) |
---|
248 | (let* ((backend (or (find-backend target) *host-backend*))) |
---|
249 | (setq fasl (cadr data) sources (caddr data)) |
---|
250 | (setq fasl (merge-pathnames (backend-target-fasl-pathname |
---|
251 | backend) fasl)) |
---|
252 | (values fasl (if (listp sources) sources (list sources)))) |
---|
253 | (error "Module ~S not defined" module))) |
---|
254 | |
---|
255 | ;compile if needed. |
---|
256 | (defun target-compile-modules (modules target force-compile) |
---|
257 | (if (not (listp modules)) (setq modules (list modules))) |
---|
258 | (in-development-mode |
---|
259 | (dolist (module modules t) |
---|
260 | (multiple-value-bind (fasl sources) (find-module module target) |
---|
261 | (if (needs-compile-p fasl sources force-compile) |
---|
262 | (progn |
---|
263 | (require'nfcomp) |
---|
264 | (compile-file (car sources) |
---|
265 | :output-file fasl |
---|
266 | :verbose t |
---|
267 | :target target))))))) |
---|
268 | |
---|
269 | |
---|
270 | (defun needs-compile-p (fasl sources force-compile) |
---|
271 | (if fasl |
---|
272 | (if (eq force-compile t) |
---|
273 | t |
---|
274 | (if (not (probe-file fasl)) |
---|
275 | t |
---|
276 | (let ((fasldate (file-write-date fasl))) |
---|
277 | (if (if (integerp force-compile) (> force-compile fasldate)) |
---|
278 | t |
---|
279 | (dolist (source sources nil) |
---|
280 | (if (> (file-write-date source) fasldate) |
---|
281 | (return t))))))))) |
---|
282 | |
---|
283 | |
---|
284 | |
---|
285 | ;;;compile if needed, load if recompiled. |
---|
286 | |
---|
287 | (defun update-modules (modules &optional force-compile) |
---|
288 | (if (not (listp modules)) (setq modules (list modules))) |
---|
289 | (in-development-mode |
---|
290 | (dolist (module modules t) |
---|
291 | (multiple-value-bind (fasl sources) (find-module module) |
---|
292 | (if (needs-compile-p fasl sources force-compile) |
---|
293 | (progn |
---|
294 | (require'nfcomp) |
---|
295 | (let* ((*warn-if-redefine* nil)) |
---|
296 | (compile-file (car sources) :output-file fasl :verbose t :load t)) |
---|
297 | (provide module))))))) |
---|
298 | |
---|
299 | (defun compile-modules (modules &optional force-compile) |
---|
300 | (target-compile-modules modules (backend-name *host-backend*) force-compile) |
---|
301 | ) |
---|
302 | |
---|
303 | (defun compile-ccl (&optional force-compile) |
---|
304 | (with-compilation-unit () |
---|
305 | (update-modules *sysdef-modules* force-compile) |
---|
306 | (update-modules 'nxenv force-compile) |
---|
307 | (update-modules *compiler-modules* force-compile) |
---|
308 | (update-modules (target-compiler-modules) force-compile) |
---|
309 | (update-modules (target-xdev-modules) force-compile) |
---|
310 | (update-modules (target-xload-modules) force-compile) |
---|
311 | (let* ((env-modules (target-env-modules)) |
---|
312 | (other-lib (target-other-lib-modules))) |
---|
313 | (require-modules env-modules) |
---|
314 | (update-modules env-modules force-compile) |
---|
315 | (compile-modules (target-level-1-modules) force-compile) |
---|
316 | (update-modules other-lib force-compile) |
---|
317 | (require-modules other-lib) |
---|
318 | (require-update-modules *code-modules* force-compile)) |
---|
319 | (compile-modules *aux-modules* force-compile))) |
---|
320 | |
---|
321 | |
---|
322 | |
---|
323 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
324 | |
---|
325 | (defun require-env (&optional force-load) |
---|
326 | (require-modules (target-env-modules) |
---|
327 | force-load)) |
---|
328 | |
---|
329 | (defun compile-level-1 (&optional force-compile) |
---|
330 | (require-env) |
---|
331 | (compile-modules (target-level-1-modules (backend-name *host-backend*)) |
---|
332 | force-compile)) |
---|
333 | |
---|
334 | |
---|
335 | |
---|
336 | |
---|
337 | |
---|
338 | (defun compile-lib (&optional force-compile) |
---|
339 | (compile-modules (target-lib-modules) |
---|
340 | force-compile)) |
---|
341 | |
---|
342 | (defun compile-code (&optional force-compile) |
---|
343 | (compile-modules *code-modules* force-compile)) |
---|
344 | |
---|
345 | |
---|
346 | ;Compile but don't load |
---|
347 | |
---|
348 | (defun xcompile-ccl (&optional force) |
---|
349 | (with-compilation-unit () |
---|
350 | (compile-modules *sysdef-modules* force) |
---|
351 | (compile-modules 'nxenv force) |
---|
352 | (compile-modules *compiler-modules* force) |
---|
353 | (compile-modules (target-compiler-modules) force) |
---|
354 | (compile-modules (target-xdev-modules) force) |
---|
355 | (compile-modules (target-xload-modules) force) |
---|
356 | (compile-modules (target-env-modules) force) |
---|
357 | (compile-modules (target-level-1-modules) force) |
---|
358 | (compile-modules (target-other-lib-modules) force) |
---|
359 | (compile-modules *code-modules* force) |
---|
360 | (compile-modules *aux-modules* force))) |
---|
361 | |
---|
362 | (defun require-update-modules (modules &optional force-compile) |
---|
363 | (if (not (listp modules)) (setq modules (list modules))) |
---|
364 | (in-development-mode |
---|
365 | (dolist (module modules) |
---|
366 | (require-modules module) |
---|
367 | (update-modules module force-compile)))) |
---|
368 | |
---|
369 | |
---|
370 | (defun target-xcompile-ccl (target &optional force) |
---|
371 | (require-update-modules *sysdef-modules* force) ;in the host |
---|
372 | (let* ((backend (or (find-backend target) *target-backend*)) |
---|
373 | (arch (backend-target-arch-name backend)) |
---|
374 | (*defstruct-share-accessor-functions* nil)) |
---|
375 | (target-compile-modules 'nxenv target force) |
---|
376 | (target-compile-modules *compiler-modules* target force) |
---|
377 | (target-compile-modules (target-compiler-modules arch) target force) |
---|
378 | (target-compile-modules (target-level-1-modules target) target force) |
---|
379 | (target-compile-modules (target-lib-modules target) target force) |
---|
380 | (target-compile-modules *sysdef-modules* target force) |
---|
381 | (target-compile-modules *aux-modules* target force) |
---|
382 | (target-compile-modules *code-modules* target force) |
---|
383 | (target-compile-modules (target-xdev-modules arch) target force))) |
---|
384 | |
---|
385 | (defun cross-compile-ccl (target &optional force) |
---|
386 | (with-cross-compilation-target (target) |
---|
387 | (let* ((*target-backend* (find-backend target))) |
---|
388 | (target-xcompile-ccl target force)))) |
---|
389 | |
---|
390 | |
---|
391 | (defun require-module (module force-load) |
---|
392 | (multiple-value-bind (fasl source) (find-module module) |
---|
393 | (setq source (car source)) |
---|
394 | (if (if fasl (probe-file fasl)) |
---|
395 | (if force-load |
---|
396 | (progn |
---|
397 | (load fasl) |
---|
398 | (provide module)) |
---|
399 | (require module fasl)) |
---|
400 | (if (probe-file source) |
---|
401 | (progn |
---|
402 | (if fasl (format t "~&Can't find ~S so requiring ~S instead" |
---|
403 | fasl source)) |
---|
404 | (if force-load |
---|
405 | (progn |
---|
406 | (load source) |
---|
407 | (provide module)) |
---|
408 | (require module source))) |
---|
409 | (error "Can't find ~S or ~S" fasl source))))) |
---|
410 | |
---|
411 | (defun require-modules (modules &optional force-load) |
---|
412 | (if (not (listp modules)) (setq modules (list modules))) |
---|
413 | (let ((*package* (find-package :ccl))) |
---|
414 | (dolist (m modules t) |
---|
415 | (require-module m force-load)))) |
---|
416 | |
---|
417 | |
---|
418 | (defun target-xcompile-level-1 (target &optional force) |
---|
419 | (target-compile-modules (target-level-1-modules target) target force)) |
---|
420 | |
---|
421 | (defun standard-boot-image-name (&optional (target (backend-name *host-backend*))) |
---|
422 | (ecase target |
---|
423 | (:darwinppc32 "ppc-boot.image") |
---|
424 | (:linuxppc32 "ppc-boot") |
---|
425 | (:darwinppc64 "ppc-boot64.image") |
---|
426 | (:linuxppc64 "ppc-boot64") |
---|
427 | (:darwinx8632 "x86-boot32.image") |
---|
428 | (:linuxx8664 "x86-boot64") |
---|
429 | (:freebsdx8664 "fx86-boot64") |
---|
430 | (:darwinx8664 "x86-boot64.image") |
---|
431 | (:solarisx8664 "sx86-boot64") |
---|
432 | (:win64 "wx86-boot64.image") |
---|
433 | (:linuxx8632 "x86-boot32") |
---|
434 | (:win32 "wx86-boot32.image") |
---|
435 | (:solarisx8632 "sx86-boot32") |
---|
436 | (:freebsdx8632 "fx86-boot32"))) |
---|
437 | |
---|
438 | (defun standard-kernel-name (&optional (target (backend-name *host-backend*))) |
---|
439 | (ecase target |
---|
440 | (:darwinppc32 "dppccl") |
---|
441 | (:linuxppc32 "ppccl") |
---|
442 | (:darwinppc64 "dppccl64") |
---|
443 | (:darwinx8632 "dx86cl") |
---|
444 | (:linuxppc64 "ppccl64") |
---|
445 | (:linuxx8664 "lx86cl64") |
---|
446 | (:freebsdx8664 "fx86cl64") |
---|
447 | (:darwinx8664 "dx86cl64") |
---|
448 | (:solarisx8664 "sx86cl64") |
---|
449 | (:win64 "wx86cl64.exe") |
---|
450 | (:linuxx8632 "lx86cl") |
---|
451 | (:win32 "wx86cl.exe") |
---|
452 | (:solarisx8632 "sx86cl") |
---|
453 | (:freebsdx8632 "fx86cl"))) |
---|
454 | |
---|
455 | (defun standard-image-name (&optional (target (backend-name *host-backend*))) |
---|
456 | (concatenate 'string (pathname-name (standard-kernel-name target)) ".image")) |
---|
457 | |
---|
458 | (defun kernel-build-directory (&optional (target (backend-name *host-backend*))) |
---|
459 | (ecase target |
---|
460 | (:darwinppc32 "darwinppc") |
---|
461 | (:linuxppc32 "linuxppc") |
---|
462 | (:darwinppc64 "darwinppc64") |
---|
463 | (:linuxppc64 "linuxppc64") |
---|
464 | (:darwinx8632 "darwinx8632") |
---|
465 | (:linuxx8664 "linuxx8664") |
---|
466 | (:freebsdx8664 "freebsdx8664") |
---|
467 | (:darwinx8664 "darwinx8664") |
---|
468 | (:solarisx8664 "solarisx64") |
---|
469 | (:win64 "win64") |
---|
470 | (:linuxx8632 "linuxx8632") |
---|
471 | (:win32 "win32") |
---|
472 | (:solarisx8632 "solarisx86") |
---|
473 | (:freebsdx8632 "freebsdx8632"))) |
---|
474 | |
---|
475 | ;;; If we distribute (e.g.) 32- and 64-bit versions for the same |
---|
476 | ;;; machine and OS in the same svn directory, return the name of the |
---|
477 | ;;; peer backend, or NIL. For example., the peer of :linuxppc64 is |
---|
478 | ;;; :linuxppc32. Note that this may change over time. |
---|
479 | ;;; Return NIL if the concept doesn't apply. |
---|
480 | (defun peer-platform (&optional (target (backend-name *host-backend*))) |
---|
481 | (let* ((pairs '((:darwinppc32 . :darwinppc64) |
---|
482 | (:linuxppc32 . :linuxppc64) |
---|
483 | (:darwinx8632 . :darwinx8664) |
---|
484 | (:linuxx8632 . :linuxx8664) |
---|
485 | (:win32 . :win64) |
---|
486 | (:solarisx8632 . :solarisx8664) |
---|
487 | (:freebsdx8632 . :freebsdx8664)))) |
---|
488 | (or (cdr (assoc target pairs)) |
---|
489 | (car (rassoc target pairs))))) |
---|
490 | |
---|
491 | (defun make-program (&optional (target (backend-name *host-backend*))) |
---|
492 | ;; The Solaris "make" program is too clever to understand -C, so |
---|
493 | ;; use GNU make (installed as "gmake"). |
---|
494 | (case target |
---|
495 | ((:solarisx8664 :solarisx8632) "gmake") |
---|
496 | (t "make"))) |
---|
497 | |
---|
498 | |
---|
499 | (defun describe-external-process-failure (proc reminder) |
---|
500 | "If it appears that the external-process PROC failed in some way, |
---|
501 | try to return a string that describes that failure. If it seems |
---|
502 | to have succeeded or if we can't tell why it failed, return NIL. |
---|
503 | This is mostly intended to describe process-creation/fork/exec failures, |
---|
504 | not runtime errors reported by a successfully created process." |
---|
505 | (multiple-value-bind (status exit-code) |
---|
506 | (external-process-status proc) |
---|
507 | (let* ((procname (car (external-process-args proc))) |
---|
508 | (string |
---|
509 | (case status |
---|
510 | (:error |
---|
511 | (%strerror exit-code)) |
---|
512 | #-windows-target |
---|
513 | (:exited |
---|
514 | (when(= exit-code #$EX_OSERR) |
---|
515 | "generic OS error in fork/exec"))))) |
---|
516 | (when string |
---|
517 | (format nil "Error executing ~a: ~a~&~a" procname string reminder))))) |
---|
518 | |
---|
519 | (defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait :unique-dcode)) |
---|
520 | (defvar *build-time-optional-features* nil) |
---|
521 | (defvar *ccl-save-source-locations* :no-text) |
---|
522 | |
---|
523 | (defun rebuild-ccl (&key update full clean kernel force (reload t) exit |
---|
524 | reload-arguments verbose optional-features |
---|
525 | (save-source-locations *ccl-save-source-locations*) |
---|
526 | (allow-constant-redefinition nil allow-constant-redefinition-p)) |
---|
527 | (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) |
---|
528 | (*features* (append *build-time-optional-features* *features*)) |
---|
529 | (*save-source-locations* save-source-locations)) |
---|
530 | (when *build-time-optional-features* |
---|
531 | (setq full t)) |
---|
532 | (when full |
---|
533 | (setq clean t kernel t reload t)) |
---|
534 | |
---|
535 | (when update |
---|
536 | (multiple-value-bind (changed conflicts new-binaries) |
---|
537 | (update-ccl :verbose (not (eq update :quiet))) |
---|
538 | (declare (ignore changed conflicts)) |
---|
539 | (when new-binaries |
---|
540 | (format t "~&There are new bootstrapping binaries. Please restart |
---|
541 | the lisp and run REBUILD-CCL again.") |
---|
542 | (return-from rebuild-ccl nil)))) |
---|
543 | (when (or clean force) |
---|
544 | ;; for better bug reports... |
---|
545 | (format t "~&Rebuilding ~a using ~a" |
---|
546 | (lisp-implementation-type) |
---|
547 | (lisp-implementation-version)) |
---|
548 | (unless allow-constant-redefinition-p |
---|
549 | (when (or force clean update) |
---|
550 | (setq allow-constant-redefinition t)))) |
---|
551 | (let* ((cd (current-directory)) |
---|
552 | (*cerror-on-constant-redefinition* (not allow-constant-redefinition )) |
---|
553 | (*warn-if-redefine-kernel* nil)) |
---|
554 | (unwind-protect |
---|
555 | (progn |
---|
556 | (setf (current-directory) "ccl:") |
---|
557 | (when clean |
---|
558 | (dolist (f (directory |
---|
559 | (merge-pathnames |
---|
560 | (make-pathname :name :wild |
---|
561 | :type (pathname-type *.fasl-pathname*)) |
---|
562 | "ccl:**;"))) |
---|
563 | (delete-file f))) |
---|
564 | (when kernel |
---|
565 | (when (or clean force) |
---|
566 | ;; Do a "make -k clean". |
---|
567 | (run-program "make" |
---|
568 | (list "-k" |
---|
569 | "-C" |
---|
570 | (format nil "lisp-kernel/~a" |
---|
571 | (kernel-build-directory)) |
---|
572 | "clean"))) |
---|
573 | (format t "~&;Building lisp-kernel ...") |
---|
574 | (with-output-to-string (s) |
---|
575 | (let* ((proc (run-program (make-program) |
---|
576 | (list "-k" "-C" |
---|
577 | (format nil "lisp-kernel/~a" |
---|
578 | (kernel-build-directory)) |
---|
579 | "-j" |
---|
580 | |
---|
581 | (format nil "~d" (1+ (cpu-count)))) |
---|
582 | :output s |
---|
583 | :error :output))) |
---|
584 | (multiple-value-bind (status exit-code) |
---|
585 | (external-process-status proc) |
---|
586 | (if (and (eq :exited status) (zerop exit-code)) |
---|
587 | (progn |
---|
588 | (format t "~&;Kernel built successfully.") |
---|
589 | (when verbose |
---|
590 | (format t "~&;kernel build output:~%~a" |
---|
591 | (get-output-stream-string s))) |
---|
592 | (sleep 1)) |
---|
593 | (error "Error(s) during kernel compilation.~%~a" |
---|
594 | (or |
---|
595 | (describe-external-process-failure |
---|
596 | proc |
---|
597 | "Developer tools may not be installed correctly.") |
---|
598 | (get-output-stream-string s)))))))) |
---|
599 | (compile-ccl (not (null force))) |
---|
600 | (if force (xload-level-0 :force) (xload-level-0)) |
---|
601 | (when reload |
---|
602 | (with-input-from-string (cmd (format nil |
---|
603 | "(save-application ~s)" |
---|
604 | (standard-image-name))) |
---|
605 | (with-output-to-string (output) |
---|
606 | (multiple-value-bind (status exit-code) |
---|
607 | (external-process-status |
---|
608 | (run-program |
---|
609 | (format nil "./~a" (standard-kernel-name)) |
---|
610 | (list* "--image-name" (standard-boot-image-name) |
---|
611 | "--batch" |
---|
612 | reload-arguments) |
---|
613 | :input cmd |
---|
614 | :output output |
---|
615 | :error output)) |
---|
616 | (if (and (eq status :exited) |
---|
617 | (eql exit-code 0)) |
---|
618 | (progn |
---|
619 | (format t "~&;Wrote heap image: ~s" |
---|
620 | (truename (format nil "ccl:~a" |
---|
621 | (standard-image-name)))) |
---|
622 | (when verbose |
---|
623 | (format t "~&;Reload heap image output:~%~a" |
---|
624 | (get-output-stream-string output)))) |
---|
625 | (error "Errors (~s ~s) reloading boot image:~&~a" |
---|
626 | status exit-code |
---|
627 | (get-output-stream-string output))))))) |
---|
628 | (when exit |
---|
629 | (quit))) |
---|
630 | (setf (current-directory) cd))))) |
---|
631 | |
---|
632 | |
---|
633 | (defun create-interfaces (dirname &key target populate-arg) |
---|
634 | (let* ((backend (if target (find-backend target) *target-backend*)) |
---|
635 | (*default-pathname-defaults* nil) |
---|
636 | (ftd (backend-target-foreign-type-data backend)) |
---|
637 | (d (use-interface-dir dirname ftd)) |
---|
638 | (populate (merge-pathnames "C/populate.sh" |
---|
639 | (merge-pathnames |
---|
640 | (interface-dir-subdir d) |
---|
641 | (ftd-interface-db-directory ftd)))) |
---|
642 | (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate)))) |
---|
643 | (args (list "-c" |
---|
644 | (format nil "cd ~a && /bin/sh ~a ~@[~a~]" |
---|
645 | (native-translated-namestring cdir) |
---|
646 | (native-translated-namestring populate) |
---|
647 | populate-arg)))) |
---|
648 | (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate) |
---|
649 | (force-output t) |
---|
650 | (multiple-value-bind (status exit-code) |
---|
651 | (external-process-status |
---|
652 | (run-program "/bin/sh" args :output t)) |
---|
653 | (if (and (eq status :exited) |
---|
654 | (eql exit-code 0)) |
---|
655 | (let* ((f 'parse-standard-ffi-files)) |
---|
656 | (require "PARSE-FFI") |
---|
657 | (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname) |
---|
658 | (funcall f dirname target) |
---|
659 | (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]") |
---|
660 | (funcall f dirname target)))))) |
---|
661 | |
---|
662 | (defun update-ccl (&key (verbose t)) |
---|
663 | (let* ((changed ()) |
---|
664 | (new-binaries ()) |
---|
665 | (conflicts ())) |
---|
666 | (with-output-to-string (out) |
---|
667 | (with-preserved-working-directory ("ccl:") |
---|
668 | (when verbose (format t "~&;Running 'svn update'.")) |
---|
669 | (multiple-value-bind (status exit-code) |
---|
670 | (external-process-status |
---|
671 | (run-program *svn-program* '("update" "--non-interactive") :output out :error t)) |
---|
672 | (when verbose (format t "~&;'svn update' complete.")) |
---|
673 | (if (not (and (eq status :exited) |
---|
674 | (eql exit-code 0))) |
---|
675 | (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code) |
---|
676 | (let* ((sout (get-output-stream-string out)) |
---|
677 | (added ()) |
---|
678 | (deleted ()) |
---|
679 | (updated ()) |
---|
680 | (merged ()) |
---|
681 | (binaries (list (standard-kernel-name) (standard-image-name ))) |
---|
682 | (peer (peer-platform))) |
---|
683 | (when peer |
---|
684 | (push (standard-kernel-name peer) binaries) |
---|
685 | (push (standard-image-name peer) binaries)) |
---|
686 | (flet ((svn-revert (string) |
---|
687 | (multiple-value-bind (status exit-code) |
---|
688 | (external-process-status (run-program *svn-program* `("revert" ,string))) |
---|
689 | (when (and (eq status :exited) (eql exit-code 0)) |
---|
690 | (setq conflicts (delete string conflicts :test #'string=)) |
---|
691 | (push string updated))))) |
---|
692 | (with-input-from-string (in sout) |
---|
693 | (do* ((line (read-line in nil nil) (read-line in nil nil))) |
---|
694 | ((null line)) |
---|
695 | (when (and (> (length line) 2) |
---|
696 | (eql #\space (schar line 1))) |
---|
697 | (let* ((path (string-trim " " (subseq line 2)))) |
---|
698 | (case (schar line 0) |
---|
699 | (#\A (push path added)) |
---|
700 | (#\D (push path deleted)) |
---|
701 | (#\U (push path updated)) |
---|
702 | (#\G (push path merged)) |
---|
703 | (#\C (push path conflicts))))))) |
---|
704 | ;; If the kernel and/or image conflict, use "svn revert" |
---|
705 | ;; to replace the working copies with the (just updated) |
---|
706 | ;; repository versions. |
---|
707 | (setq changed (if (or added deleted updated merged conflicts) t)) |
---|
708 | (dolist (f binaries) |
---|
709 | (cond ((member f conflicts :test #'string=) |
---|
710 | (svn-revert f) |
---|
711 | (setq new-binaries t)) |
---|
712 | ((or (member f updated :test #'string=) |
---|
713 | (member f merged :test #'string=)) |
---|
714 | (setq new-binaries t)))) |
---|
715 | |
---|
716 | ;; If there are any remaining conflicts, offer |
---|
717 | ;; to revert them. |
---|
718 | (when conflicts |
---|
719 | (with-preserved-working-directory () |
---|
720 | (cerror "Discard local changes to these files (using 'svn revert')." |
---|
721 | "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~}" (length conflicts) conflicts) |
---|
722 | (dolist (c (copy-list conflicts)) |
---|
723 | (svn-revert c)))) |
---|
724 | ;; Report other changes, if verbose. |
---|
725 | (when (and verbose |
---|
726 | (or added deleted updated merged conflicts)) |
---|
727 | (format t "~&;Changes from svn update:") |
---|
728 | (flet ((show-changes (herald files) |
---|
729 | (when files |
---|
730 | (format t "~&; ~a:~{~&; ~a~}" |
---|
731 | herald files)))) |
---|
732 | (show-changes "Conflicting files" conflicts) |
---|
733 | (show-changes "New files/directories" added) |
---|
734 | (show-changes "Deleted files/directories" deleted) |
---|
735 | (show-changes "Updated files" updated) |
---|
736 | (show-changes "Files with local changes, successfully merged" merged))))))))) |
---|
737 | (values changed conflicts new-binaries))) |
---|
738 | |
---|
739 | (defmacro with-preserved-working-directory ((&optional dir) &body body) |
---|
740 | (let ((wd (gensym))) |
---|
741 | `(let ((,wd (mac-default-directory))) |
---|
742 | (unwind-protect |
---|
743 | (progn |
---|
744 | ,@(when dir `((cwd ,dir))) |
---|
745 | ,@body) |
---|
746 | (cwd ,wd))))) |
---|
747 | |
---|
748 | (defun ensure-tests-loaded (&key force update ansi ccl) |
---|
749 | (unless (and (find-package "REGRESSION-TEST") (not force)) |
---|
750 | (if (probe-file "ccl:tests;ansi-tests;") |
---|
751 | (when update |
---|
752 | (cwd "ccl:tests;") |
---|
753 | (run-program *svn-program* '("update"))) |
---|
754 | (let* ((repo (svn-repository)) |
---|
755 | (url (format nil "~a/trunk/tests" repo)) |
---|
756 | (s (make-string-output-stream))) |
---|
757 | (if (null repo) |
---|
758 | (error "Can't determine svn repository. ccl directory is ~s" |
---|
759 | (ccl-directory)) |
---|
760 | (progn |
---|
761 | (format t "~&Using ~a to check out test suite from ~a ~ |
---|
762 | into ccl:tests;~%" *svn-program* url) |
---|
763 | (cwd "ccl:") |
---|
764 | (multiple-value-bind (status exit-code) |
---|
765 | (external-process-status |
---|
766 | (run-program *svn-program* (list "checkout" url "tests") |
---|
767 | :output s :error s)) |
---|
768 | (unless (and (eq status :exited) |
---|
769 | (eql exit-code 0)) |
---|
770 | (error "Failed to check out test suite: ~%~a" |
---|
771 | (get-output-stream-string s)))))))) |
---|
772 | (cwd "ccl:tests;ansi-tests;") |
---|
773 | (run-program "make" '("-k" "clean")) |
---|
774 | (map nil 'delete-file (directory "*.*fsl")) |
---|
775 | ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about |
---|
776 | ;; it without making the test suite non-portable across platforms... |
---|
777 | (handler-bind ((warning (lambda (c) |
---|
778 | (when (let ((w (or (and (typep c 'compiler-warning) |
---|
779 | (eq (compiler-warning-warning-type c) :program-error) |
---|
780 | (car (compiler-warning-args c))) |
---|
781 | c))) |
---|
782 | (and (typep w 'simple-warning) |
---|
783 | (or |
---|
784 | (string-equal |
---|
785 | (simple-condition-format-control w) |
---|
786 | "Clause ~S ignored in ~S form - shadowed by ~S .") |
---|
787 | ;; Might as well ignore these as well, they're intentional. |
---|
788 | (string-equal |
---|
789 | (simple-condition-format-control w) |
---|
790 | "Duplicate keyform ~s in ~s statement.")))) |
---|
791 | (muffle-warning c))))) |
---|
792 | ;; This loads the infrastructure |
---|
793 | (load "ccl:tests;ansi-tests;gclload1.lsp") |
---|
794 | ;; This loads the actual tests |
---|
795 | (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST))) |
---|
796 | (progv (list redef-var) (list (if force nil (symbol-value redef-var))) |
---|
797 | (when ansi |
---|
798 | (load "ccl:tests;ansi-tests;gclload2.lsp")) |
---|
799 | ;; And our own tests |
---|
800 | (when ccl |
---|
801 | (load "ccl:tests;ansi-tests;ccl.lsp"))))))) |
---|
802 | |
---|
803 | (defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t) |
---|
804 | optimization-settings exit) |
---|
805 | (with-preserved-working-directory () |
---|
806 | (let* ((*package* (find-package "CL-USER"))) |
---|
807 | (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl) |
---|
808 | (cwd "ccl:tests;ansi-tests;") |
---|
809 | (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST")) |
---|
810 | (failed (find-symbol "*FAILED-TESTS*" "REGRESSION-TEST")) |
---|
811 | (*print-catch-errors* nil)) |
---|
812 | (prog1 |
---|
813 | (time (funcall do-tests :verbose verbose :compile t |
---|
814 | :catch-errors catch-errors |
---|
815 | :optimization-settings (or optimization-settings '((safety 2))))) |
---|
816 | ;; Clean up a little |
---|
817 | (map nil #'delete-file |
---|
818 | (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*")))) |
---|
819 | (let ((failed-tests (symbol-value failed))) |
---|
820 | (when exit |
---|
821 | (quit (if failed-tests 1 0))) |
---|
822 | failed-tests))))) |
---|
823 | |
---|