source: branches/gz-working/lib/compile-ccl.lisp @ 8505

Last change on this file since 8505 was 8505, checked in by gz, 13 years ago

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.4 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))
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                           
Note: See TracBrowser for help on using the repository browser.