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

Last change on this file since 14119 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

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