source: branches/working-0711/ccl/lib/compile-ccl.lisp @ 9365

Last change on this file since 9365 was 9365, checked in by gz, 11 years ago

New :UNIQUE-DCODE optional feature:

if ccl is built with

(rebuild-ccl :optional-features '(:unique-dcode))

then each generic function will have its own unique copy
of its dcode, whose name is a list (dcode-name gf-name).

This feature is not recommend for real use (for one thing,
it's known to break gf tracing), but may be helpful for
profiling.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(require 'systems)
20
21; Interim PPC support
22; sequences is here since l1-typesys REQUIREs it
23(defparameter *level-1-modules*
24  '(level-1
25    l1-cl-package
26    l1-boot-1 l1-boot-2 l1-boot-3
27    l1-utils l1-init l1-symhash l1-numbers l1-aprims 
28    l1-sort l1-dcode l1-clos-boot l1-clos
29    l1-unicode l1-streams l1-files l1-io 
30    l1-format l1-readloop l1-reader
31    l1-sysio l1-pathnames l1-events
32    l1-boot-lds  l1-readloop-lds 
33    l1-lisp-threads  l1-application l1-processes
34    l1-typesys sysutils l1-error-system
35    l1-error-signal version l1-callbacks
36    l1-sockets linux-files
37
38    ))
39
40(defparameter *compiler-modules*
41      '(nx optimizers dll-node arch vreg vinsn 
42        reg subprims  backend))
43
44
45(defparameter *ppc-compiler-modules*
46  '(ppc32-arch
47    ppc64-arch
48    ppc-arch
49    ppcenv
50    ppc-asm
51    risc-lap
52    ppc-lap
53    ppc-backend
54))
55
56(defparameter *x86-compiler-modules*
57  '(x86-arch
58    x86-asm
59    x86-lap
60    x8664-arch
61    x8664env
62    x86-backend
63    )
64  )
65
66(defparameter *ppc32-compiler-backend-modules*
67  '(ppc32-backend ppc32-vinsns))
68
69(defparameter *ppc64-compiler-backend-modules*
70  '(ppc64-backend ppc64-vinsns))
71
72
73(defparameter *ppc-compiler-backend-modules*
74  '(ppc2))
75
76
77(defparameter *x8632-compiler-backend-modules*
78  '(x8632-backend x8632-vinsns))
79
80(defparameter *x8664-compiler-backend-modules*
81  '(x8664-backend x8664-vinsns))
82
83(defparameter *x86-compiler-backend-modules*
84  '(x862))
85
86
87
88
89(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image ))
90(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
91
92
93;;; Not too OS-specific.
94(defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
95(defparameter *x86-xdev-modules* '(x86-lapmacros ))
96
97(defun target-xdev-modules (&optional (target
98                                       (backend-target-arch-name
99                                        *host-backend*)))
100  (case target
101    ((:ppc32 :ppc64) *ppc-xdev-modules*)
102    ((:x8632 :x8664) *x86-xdev-modules*)))
103
104(defun target-xload-modules (&optional (target
105                                        (backend-target-arch-name *host-backend*)))
106  (case target
107    ((:ppc32 :ppc64) *ppc-xload-modules*)
108    (:x8664 *x8664-xload-modules*)))
109
110
111
112
113
114
115(defparameter *env-modules*
116  '(hash backquote lispequ  level-2 macros
117    defstruct-macros lists chars setf setf-runtime
118    defstruct defstruct-lds 
119    foreign-types
120    db-io
121    nfcomp
122    ))
123
124(defun target-env-modules (&optional (target
125                                      (backend-name *host-backend*)))
126  (append *env-modules*
127          (list
128           (ecase target
129             (:linuxppc32 'ffi-linuxppc32)
130             (:darwinppc32 'ffi-darwinppc32)
131             (:darwinppc64 'ffi-darwinppc64)
132             (:linuxppc64 'ffi-linuxppc64)
133             (:linuxx8664 'ffi-linuxx8664)
134             (:darwinx8664 'ffi-darwinx8664)
135             (:freebsdx8664 'ffi-freebsdx8664)))))
136
137
138(defun target-compiler-modules (&optional (target
139                                           (backend-target-arch-name
140                                            *host-backend*)))
141  (case target
142    (:ppc32 (append *ppc-compiler-modules*
143                    *ppc32-compiler-backend-modules*
144                    *ppc-compiler-backend-modules*))
145    (:ppc64 (append *ppc-compiler-modules*
146                    *ppc64-compiler-backend-modules*
147                    *ppc-compiler-backend-modules*))
148    (:x8664 (append *x86-compiler-modules*
149                    *x8664-compiler-backend-modules*
150                    *x86-compiler-backend-modules*))))
151
152(defparameter *other-lib-modules*
153  '(streams pathnames backtrace
154    apropos
155    numbers 
156    dumplisp   source-files))
157
158(defun target-other-lib-modules (&optional (target
159                                            (backend-target-arch-name
160                                             *host-backend*)))
161  (append *other-lib-modules*
162          (case target
163            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
164            (:x8664 '(x86-backtrace x86-disassemble)))))
165         
166
167(defun target-lib-modules (&optional (backend-name
168                                      (backend-name *host-backend*)))
169  (let* ((backend (or (find-backend backend-name) *host-backend*))
170         (arch-name (backend-target-arch-name backend)))
171    (append (target-env-modules backend-name) (target-other-lib-modules arch-name))))
172
173
174(defparameter *code-modules*
175      '(encapsulate
176        read misc  arrays-fry
177        sequences sort 
178        method-combination
179        case-error pprint 
180        format time 
181;        eval step
182        backtrace-lds  ccl-export-syms prepare-mcl-environment))
183
184
185
186(defparameter *aux-modules*
187      '(systems compile-ccl 
188        lisp-package
189        number-macros number-case-macro
190        loop
191        runtime
192        mcl-compat
193        arglist
194        edit-callers
195        describe
196        cover
197        asdf
198        defsystem
199))
200
201
202
203
204
205
206
207(defun target-level-1-modules (&optional (target (backend-name *host-backend*)))
208  (append *level-1-modules*
209          (case target
210            ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
211             '(ppc-error-signal ppc-trap-support
212               ppc-threads-utils ppc-callback-support))
213            ((:linuxx8664 :freebsdx8664 :darwinx8664)
214             '(x86-error-signal x86-trap-support
215               x86-threads-utils x86-callback-support)))))
216
217                 
218
219
220
221
222;
223
224
225
226
227
228; Needed to cross-dump an image
229
230
231
232(unless (fboundp 'xload-level-0)
233  (%fhave 'xload-level-0
234          #'(lambda (&rest rest)
235              (in-development-mode
236               (require-modules (target-xload-modules)))
237              (apply 'xload-level-0 rest))))
238
239(defun find-module (module &optional (target (backend-name *host-backend*))  &aux data fasl sources)
240  (if (setq data (assoc module *ccl-system*))
241    (let* ((backend (or (find-backend target) *host-backend*)))
242      (setq fasl (cadr data) sources (caddr data))     
243      (setq fasl (merge-pathnames (backend-target-fasl-pathname
244                                   backend) fasl))
245      (values fasl (if (listp sources) sources (list sources))))
246    (error "Module ~S not defined" module)))
247
248;compile if needed.
249(defun target-compile-modules (modules target force-compile)
250  (if (not (listp modules)) (setq modules (list modules)))
251  (in-development-mode
252   (dolist (module modules t)
253     (multiple-value-bind (fasl sources) (find-module module target)
254      (if (needs-compile-p fasl sources force-compile)
255        (progn
256          (require'nfcomp)
257          (compile-file (car sources)
258                        :output-file fasl
259                        :verbose t
260                        :target target)))))))
261
262
263
264
265
266
267(defun needs-compile-p (fasl sources force-compile)
268  (if fasl
269    (if (eq force-compile t)
270      t
271      (if (not (probe-file fasl))
272        t
273        (let ((fasldate (file-write-date fasl)))
274          (if (if (integerp force-compile) (> force-compile fasldate))
275            t
276            (dolist (source sources nil)
277              (if (> (file-write-date source) fasldate)
278                (return t)))))))))
279
280
281
282;compile if needed, load if recompiled.
283
284(defun update-modules (modules &optional force-compile)
285  (if (not (listp modules)) (setq modules (list modules)))
286  (in-development-mode
287   (dolist (module modules t)
288     (multiple-value-bind (fasl sources) (find-module module)
289       (if (needs-compile-p fasl sources force-compile)
290         (progn
291           (require'nfcomp)
292           (let* ((*warn-if-redefine* nil))
293             (compile-file (car sources) :output-file fasl :verbose t :load t))
294           (provide module)))))))
295
296(defun compile-modules (modules &optional force-compile)
297  (target-compile-modules modules (backend-name *host-backend*) force-compile)
298)
299
300(defun compile-ccl (&optional force-compile)
301  (update-modules 'nxenv force-compile)
302  (update-modules *compiler-modules* force-compile)
303  (update-modules (target-compiler-modules) force-compile)
304  (update-modules (target-xdev-modules) force-compile)
305  (update-modules (target-xload-modules)  force-compile)
306  (let* ((env-modules (target-env-modules))
307         (other-lib (target-other-lib-modules)))
308    (require-modules env-modules)
309    (update-modules env-modules force-compile)
310    (compile-modules (target-level-1-modules)  force-compile)
311    (update-modules other-lib force-compile)
312    (require-modules other-lib)
313    (require-update-modules *code-modules* force-compile))
314  (compile-modules *aux-modules* force-compile))
315
316
317
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319
320(defun require-env (&optional force-load)
321  (require-modules  (target-env-modules)
322                   force-load))
323
324(defun compile-level-1 (&optional force-compile)
325  (require-env)
326  (compile-modules (target-level-1-modules (backend-name *host-backend*))
327                   force-compile))
328
329
330
331
332
333(defun compile-lib (&optional force-compile)
334  (compile-modules (target-lib-modules)
335                   force-compile))
336
337(defun compile-code (&optional force-compile)
338  (compile-modules *code-modules* force-compile))
339
340
341;Compile but don't load
342
343(defun xcompile-ccl (&optional force)
344  (compile-modules 'nxenv force)
345  (compile-modules *compiler-modules* force)
346  (compile-modules (target-compiler-modules) force)
347  (compile-modules (target-xdev-modules) force)
348  (compile-modules (target-xload-modules)  force)
349  (compile-modules (target-env-modules) force)
350  (compile-modules (target-level-1-modules) force)
351  (compile-modules (target-other-lib-modules) force)
352  (compile-modules *code-modules* force)
353  (compile-modules *aux-modules* force))
354
355(defun require-update-modules (modules &optional force-compile)
356  (if (not (listp modules)) (setq modules (list modules)))
357  (in-development-mode
358    (dolist (module modules)
359    (require-modules module)
360    (update-modules module force-compile))))
361
362(defun compile-level-1 (&optional force-compile)
363  (compile-modules (target-level-1-modules (backend-name *host-backend*))
364                   force-compile))
365
366
367
368 
369
370(defun target-xcompile-ccl (target &optional force)
371  (let* ((backend (or (find-backend target) *target-backend*))
372         (arch (backend-target-arch-name backend))
373         (*defstruct-share-accessor-functions* nil))
374    (target-compile-modules 'nxenv target force)
375    (target-compile-modules *compiler-modules* target force)
376    (target-compile-modules (target-compiler-modules arch) target force)
377    (target-compile-modules (target-level-1-modules target) target force)
378    (target-compile-modules (target-lib-modules target) target force)
379    (target-compile-modules *aux-modules* target force)
380    (target-compile-modules *code-modules* target force)
381    (target-compile-modules (target-xdev-modules arch) target force)))
382
383(defun cross-compile-ccl (target &optional force)
384  (with-cross-compilation-target (target)
385    (let* ((*target-backend* (find-backend target)))
386      (target-xcompile-ccl target force))))
387
388
389(defun require-module (module force-load)
390  (multiple-value-bind (fasl source) (find-module module)
391      (setq source (car source))
392      (if (if fasl (probe-file fasl))
393        (if force-load
394          (progn
395            (load fasl)
396            (provide module))
397          (require module fasl))
398        (if (probe-file source)
399          (progn
400            (if fasl (format t "~&Can't find ~S so requiring ~S instead"
401                             fasl source))
402            (if force-load
403              (progn
404                (load source)
405                (provide module))
406              (require module source)))
407          (error "Can't find ~S or ~S" fasl source)))))
408
409(defun require-modules (modules &optional force-load)
410  (if (not (listp modules)) (setq modules (list modules)))
411  (let ((*package* (find-package :ccl)))
412    (dolist (m modules t)
413      (require-module m force-load))))
414
415
416(defun target-xcompile-level-1 (target &optional force)
417  (target-compile-modules (target-level-1-modules target) target force))
418
419(defun standard-boot-image-name (&optional (target (backend-name *host-backend*)))
420  (ecase target
421    (:darwinppc32 "ppc-boot.image")
422    (:linuxppc32 "ppc-boot")
423    (:darwinppc64 "ppc-boot64.image")
424    (:linuxppc64 "ppc-boot64")
425    (:linuxx8664 "x86-boot64")
426    (:freebsdx8664 "fx86-boot64")
427    (:darwinx8664 "x86-boot64.image")))
428
429(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
430  (ecase target
431    (:darwinppc32 "dppccl")
432    (:linuxppc32 "ppccl")
433    (:darwinppc64 "dppccl64")
434    (:linuxppc64 "ppccl64")
435    (:linuxx8664 "lx86cl64")
436    (:freebsdx8664 "fx86cl64")
437    (:darwinx8664 "dx86cl64")))
438
439(defun standard-image-name (&optional (target (backend-name *host-backend*)))
440  (ecase target
441    (:darwinppc32 "dppccl.image")
442    (:linuxppc32 "PPCCL")
443    (:darwinppc64 "dppccl64.image")
444    (:linuxppc64 "PPCCL64")
445    (:linuxx8664 "LX86CL64")
446    (:freebsdx8664 "FX86CL64")
447    (:darwinx8664 "dx86cl64.image")))
448
449(defun kernel-build-directory (&optional (target (backend-name *host-backend*)))
450  (ecase target
451    (:darwinppc32 "darwinppc")
452    (:linuxppc32 "linuxppc")
453    (:darwinppc64 "darwinppc64")
454    (:linuxppc64 "linuxppc64")
455    (:linuxx8664 "linuxx8664")
456    (:freebsdx8664 "freebsdx8664")
457    (:darwinx8664 "darwinx8664")))
458
459(defparameter *known-optional-features* '(:lock-accouting :count-gf-calls :monitor-futex-wait :unique-dcode))
460(defvar *build-time-optional-features* nil)
461
462
463(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features)
464  (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features))
465         (*features* (append *build-time-optional-features* *features*)))
466    (when *build-time-optional-features*
467      (setq full t))
468    (when full
469      (setq clean t kernel t reload t))
470    (when update (update-ccl))
471    (let* ((cd (current-directory)))
472      (unwind-protect
473           (progn
474             (setf (current-directory) "ccl:")
475             (when clean
476               (dolist (f (directory
477                           (merge-pathnames
478                            (make-pathname :name :wild
479                                           :type (pathname-type *.fasl-pathname*))
480                            "ccl:**;")))
481                 (delete-file f)))
482             (when kernel
483               (when (or clean force)
484                 ;; Do a "make -k clean".
485                 (run-program "make"
486                              (list "-k"
487                                    "-C"
488                                    (format nil "lisp-kernel/~a"
489                                            (kernel-build-directory))
490                                    "clean")))
491               (format t "~&;Building lisp-kernel ...")
492               (with-output-to-string (s)
493                                      (multiple-value-bind
494                                          (status exit-code)
495                                          (external-process-status 
496                                           (run-program "make"
497                                                        (list "-k" "-C" 
498                                                              (format nil "lisp-kernel/~a"
499                                                                      (kernel-build-directory))
500                                                              "-j"
501                                                           
502                                                              (format nil "~d" (1+ (cpu-count))))
503                                                        :output s
504                                                        :error s))
505                                        (if (and (eq :exited status) (zerop exit-code))
506                                          (progn
507                                            (format t "~&;Kernel built successfully.")
508                                            (when verbose
509                                              (format t "~&;kernel build output:~%~a"
510                                                      (get-output-stream-string s)))
511                                            (sleep 1))
512                                          (error "Error(s) during kernel compilation.~%~a"
513                                                 (get-output-stream-string s))))))
514             (compile-ccl (not (null force)))
515             (if force (xload-level-0 :force) (xload-level-0))
516             (when reload
517               (with-input-from-string (cmd (format nil
518                                                    "(save-application ~s)"
519                                                    (standard-image-name)))
520                 (with-output-to-string (output)
521                                        (multiple-value-bind (status exit-code)
522                                            (external-process-status
523                                             (run-program
524                                              (format nil "./~a" (standard-kernel-name))
525                                              (list* "--image-name" (standard-boot-image-name)
526                                                     reload-arguments)
527                                              :input cmd
528                                              :output output
529                                              :error output))
530                                          (if (and (eq status :exited)
531                                                   (eql exit-code 0))
532                                            (progn
533                                              (format t "~&;Wrote heap image: ~s"
534                                                      (truename (format nil "ccl:~a"
535                                                                        (standard-image-name))))
536                                              (when verbose
537                                                (format t "~&;Reload heap image output:~%~a"
538                                                        (get-output-stream-string output))))
539                                            (error "Errors (~s ~s) reloading boot image:~&~a"
540                                                   status exit-code
541                                                   (get-output-stream-string output)))))))
542             (when exit
543               (quit)))
544        (setf (current-directory) cd)))))
545                                                 
546               
547(defun create-interfaces (dirname &key target populate-arg)
548  (let* ((backend (if target (find-backend target) *target-backend*))
549         (*default-pathname-defaults* nil)
550         (ftd (backend-target-foreign-type-data backend))
551         (d (use-interface-dir dirname ftd))
552         (populate (merge-pathnames "C/populate.sh"
553                                    (merge-pathnames
554                                     (interface-dir-subdir d)
555                                     (ftd-interface-db-directory ftd))))
556         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
557         (args (list "-c"
558                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
559                             (native-translated-namestring cdir)
560                             (native-translated-namestring populate)
561                             populate-arg))))
562    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
563    (force-output t)
564    (multiple-value-bind (status exit-code)
565        (external-process-status
566         (run-program "/bin/sh" args :output t))
567      (if (and (eq status :exited)
568               (eql exit-code 0))
569        (let* ((f 'parse-standard-ffi-files))
570          (require "PARSE-FFI")
571          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
572          (funcall f dirname target)
573          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
574          (funcall f dirname target))))))
575
576(defun update-ccl ()
577  (let* ((cvs-update "cvs -q update -d -P")
578         (svn-update "svn update")
579         (use-cvs (probe-file "ccl:\.svnrev"))
580         (s (make-string-output-stream)))
581    (multiple-value-bind (status exit-code)
582        (external-process-status
583         (run-program "/bin/sh"
584                      (list "-c"
585                            (format nil "cd ~a && ~a"
586                                    (native-translated-namestring "ccl:")
587                                    (if use-cvs cvs-update svn-update)))
588                      :output s))
589      (when (and (eq status :exited)
590                 (eql exit-code 0))
591        (format t "~&~a" (get-output-stream-string s))
592        t))))
593
594(defmacro with-preserved-working-directory ((&optional dir) &body body)
595  (let ((wd (gensym)))
596    `(let ((,wd (mac-default-directory)))
597       (unwind-protect
598            (progn 
599              ,@(when dir `((cwd ,dir)))
600              ,@body)
601         (cwd ,wd)))))
602
603(defun ensure-tests-loaded (&key force update)
604  (unless (and (find-package "REGRESSION-TEST") (not force))
605    (if (probe-file "ccl:tests;ansi-tests;")
606      (when update
607        (cwd "ccl:tests;")
608        (run-program "svn" '("update")))
609      (let* ((svn (probe-file "ccl:.svn;entries"))
610             (repo (and svn (svn-repository)))
611             (s (make-string-output-stream)))
612        (when repo
613          (format t "~&Checking out test suite into ccl:tests;~%")
614          (cwd "ccl:")
615          (multiple-value-bind (status exit-code)
616              (external-process-status
617               (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests")
618                            :output s
619                            :error s))
620            (unless (and (eq status :exited)
621                         (eql exit-code 0))
622              (error "Failed to check out test suite: ~%~a" (get-output-stream-string s)))))))
623    (cwd "ccl:tests;ansi-tests;")
624    (run-program "make" '("-k" "clean"))
625    (map nil 'delete-file (directory "*.*fsl"))
626    ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about
627    ;; it without making the test suite non-portable across platforms...
628    (handler-bind ((warning (lambda (c)
629                              (when (let ((w (or (and (typep c 'compiler-warning)
630                                                      (eq (compiler-warning-warning-type c) :program-error)
631                                                      (car (compiler-warning-args c)))
632                                                 c)))
633                                      (and (typep w 'simple-warning)
634                                           (or 
635                                            (string-equal
636                                             (simple-condition-format-control w)
637                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
638                                            ;; Might as well ignore these as well, they're intentional.
639                                            (string-equal
640                                             (simple-condition-format-control w)
641                                             "Duplicate keyform ~s in ~s statement."))))
642                                (muffle-warning c)))))
643      ;; This loads the infrastructure
644      (load "ccl:tests;ansi-tests;gclload1.lsp")
645      ;; Can't put this in the source, because currently tests are not branched
646      (eval `(define-definition-type ,(find-symbol "DEFTEST" "CL-TEST")
647                 (function-definition-type)))
648      ;; This loads the actual tests
649      (load "ccl:tests;ansi-tests;gclload2.lsp")
650      ;; And our own tests
651      (load "ccl:tests;ansi-tests;ccl.lsp"))))
652
653(defun test-ccl (&key force (update t) verbose (catch-errors t))
654  (with-preserved-working-directory ()
655    (ensure-tests-loaded :force force :update update)
656    (cwd "ccl:tests;ansi-tests;")
657    (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
658          (*suppress-compiler-warnings* t)
659          (*print-catch-errors* nil))
660      (time (funcall do-tests :verbose verbose :compile t :catch-errors catch-errors)))
661    ;; Ok, here we would run any of our own tests.
662    ))
Note: See TracBrowser for help on using the repository browser.