source: trunk/source/lib/compile-ccl.lisp @ 15707

Last change on this file since 15707 was 15707, checked in by gb, 6 years ago

REBUILD-CCL: if building the kernel, do so after rebuilding the bootstrapping
image. (This can make it simpler to generate images whose svn revision
doesn't contain an "M" suffix in some cases.)

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