source: branches/ia32/lib/compile-ccl.lisp @ 9626

Last change on this file since 9626 was 9626, checked in by rme, 11 years ago

Use dx86cl and dx86cl.image for standard-kernel-name and standard-image-name.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.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  '(x8632-arch
58    x8664-arch
59    x86-arch
60    x8632env
61    x8664env
62    x86-asm
63    x86-lap
64    x86-backend
65))
66
67(defparameter *ppc32-compiler-backend-modules*
68  '(ppc32-backend ppc32-vinsns))
69
70(defparameter *ppc64-compiler-backend-modules*
71  '(ppc64-backend ppc64-vinsns))
72
73
74(defparameter *ppc-compiler-backend-modules*
75  '(ppc2))
76
77
78(defparameter *x8632-compiler-backend-modules*
79  '(x8632-backend x8632-vinsns))
80
81(defparameter *x8664-compiler-backend-modules*
82  '(x8664-backend x8664-vinsns))
83
84(defparameter *x86-compiler-backend-modules*
85  '(x862))
86
87
88
89
90(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image ))
91(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image ))
92(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image ))
93
94
95;;; Not too OS-specific.
96(defparameter *ppc-xdev-modules* '(ppc-lapmacros ))
97(defparameter *x86-xdev-modules* '(x86-lapmacros ))
98
99(defun target-xdev-modules (&optional (target
100                                       (backend-target-arch-name
101                                        *host-backend*)))
102  (case target
103    ((:ppc32 :ppc64) *ppc-xdev-modules*)
104    ((:x8632 :x8664) *x86-xdev-modules*)))
105
106(defun target-xload-modules (&optional (target
107                                        (backend-target-arch-name *host-backend*)))
108  (case target
109    ((:ppc32 :ppc64) *ppc-xload-modules*)
110    (:x8632 *x8632-xload-modules*)
111    (:x8664 *x8664-xload-modules*)))
112
113
114
115
116
117
118(defparameter *env-modules*
119  '(hash backquote lispequ  level-2 macros
120    defstruct-macros lists chars setf setf-runtime
121    defstruct defstruct-lds 
122    foreign-types
123    db-io
124    nfcomp
125    ))
126
127(defun target-env-modules (&optional (target
128                                      (backend-name *host-backend*)))
129  (append *env-modules*
130          (list
131           (ecase target
132             (:linuxppc32 'ffi-linuxppc32)
133             (:darwinppc32 'ffi-darwinppc32)
134             (:darwinppc64 'ffi-darwinppc64)
135             (:linuxppc64 'ffi-linuxppc64)
136             (:darwinx8632 'ffi-darwinx8632)
137             (:linuxx8664 'ffi-linuxx8664)
138             (:darwinx8664 'ffi-darwinx8664)
139             (:freebsdx8664 'ffi-freebsdx8664)))))
140
141
142(defun target-compiler-modules (&optional (target
143                                           (backend-target-arch-name
144                                            *host-backend*)))
145  (case target
146    (:ppc32 (append *ppc-compiler-modules*
147                    *ppc32-compiler-backend-modules*
148                    *ppc-compiler-backend-modules*))
149    (:ppc64 (append *ppc-compiler-modules*
150                    *ppc64-compiler-backend-modules*
151                    *ppc-compiler-backend-modules*))
152    (:x8632 (append *x86-compiler-modules*
153                    *x8632-compiler-backend-modules*
154                    *x86-compiler-backend-modules*))
155    (:x8664 (append *x86-compiler-modules*
156                    *x8664-compiler-backend-modules*
157                    *x86-compiler-backend-modules*))))
158
159(defparameter *other-lib-modules*
160  '(streams pathnames backtrace
161    apropos
162    numbers 
163    dumplisp   source-files))
164
165(defun target-other-lib-modules (&optional (target
166                                            (backend-target-arch-name
167                                             *host-backend*)))
168  (append *other-lib-modules*
169          (case target
170            ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble))
171            ((:x8632 :x8664) '(x86-backtrace x86-disassemble)))))
172         
173
174(defun target-lib-modules (&optional (backend-name
175                                      (backend-name *host-backend*)))
176  (let* ((backend (or (find-backend backend-name) *host-backend*))
177         (arch-name (backend-target-arch-name backend)))
178    (append (target-env-modules backend-name) (target-other-lib-modules arch-name))))
179
180
181(defparameter *code-modules*
182      '(encapsulate
183        read misc  arrays-fry
184        sequences sort 
185        method-combination
186        case-error pprint 
187        format time 
188;        eval step
189        backtrace-lds  ccl-export-syms prepare-mcl-environment))
190
191
192
193(defparameter *aux-modules*
194      '(systems compile-ccl 
195        lisp-package
196        number-macros number-case-macro
197        loop
198        runtime
199        mcl-compat
200        arglist
201        edit-callers
202        hash-cons
203        describe
204        asdf
205        defsystem
206))
207
208
209
210
211
212
213
214(defun target-level-1-modules (&optional (target (backend-name *host-backend*)))
215  (append *level-1-modules*
216          (case target
217            ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64)
218             '(ppc-error-signal ppc-trap-support
219               ppc-threads-utils ppc-callback-support))
220            ((:darwinx8632 :linuxx8664 :freebsdx8664 :darwinx8664)
221             '(x86-error-signal x86-trap-support
222               x86-threads-utils x86-callback-support)))))
223
224                 
225
226
227
228
229;
230
231
232
233
234
235; Needed to cross-dump an image
236
237
238
239(unless (fboundp 'xload-level-0)
240  (%fhave 'xload-level-0
241          #'(lambda (&rest rest)
242              (in-development-mode
243               (require-modules (target-xload-modules)))
244              (apply 'xload-level-0 rest))))
245
246(defun find-module (module &optional (target (backend-name *host-backend*))  &aux data fasl sources)
247  (if (setq data (assoc module *ccl-system*))
248    (let* ((backend (or (find-backend target) *host-backend*)))
249      (setq fasl (cadr data) sources (caddr data))     
250      (setq fasl (merge-pathnames (backend-target-fasl-pathname
251                                   backend) fasl))
252      (values fasl (if (listp sources) sources (list sources))))
253    (error "Module ~S not defined" module)))
254
255;compile if needed.
256(defun target-compile-modules (modules target force-compile)
257  (if (not (listp modules)) (setq modules (list modules)))
258  (in-development-mode
259   (dolist (module modules t)
260     (multiple-value-bind (fasl sources) (find-module module target)
261      (if (needs-compile-p fasl sources force-compile)
262        (progn
263          (require'nfcomp)
264          (compile-file (car sources)
265                        :output-file fasl
266                        :verbose t
267                        :target target)))))))
268
269
270
271
272
273
274(defun needs-compile-p (fasl sources force-compile)
275  (if fasl
276    (if (eq force-compile t)
277      t
278      (if (not (probe-file fasl))
279        t
280        (let ((fasldate (file-write-date fasl)))
281          (if (if (integerp force-compile) (> force-compile fasldate))
282            t
283            (dolist (source sources nil)
284              (if (> (file-write-date source) fasldate)
285                (return t)))))))))
286
287
288
289;compile if needed, load if recompiled.
290
291(defun update-modules (modules &optional force-compile)
292  (if (not (listp modules)) (setq modules (list modules)))
293  (in-development-mode
294   (dolist (module modules t)
295     (multiple-value-bind (fasl sources) (find-module module)
296       (if (needs-compile-p fasl sources force-compile)
297         (progn
298           (require'nfcomp)
299           (let* ((*warn-if-redefine* nil))
300             (compile-file (car sources) :output-file fasl :verbose t :load t))
301           (provide module)))))))
302
303(defun compile-modules (modules &optional force-compile)
304  (target-compile-modules modules (backend-name *host-backend*) force-compile)
305)
306
307(defun compile-ccl (&optional force-compile)
308  (update-modules 'nxenv force-compile)
309  (update-modules *compiler-modules* force-compile)
310  (update-modules (target-compiler-modules) force-compile)
311  (update-modules (target-xdev-modules) force-compile)
312  (update-modules (target-xload-modules)  force-compile)
313  (let* ((env-modules (target-env-modules))
314         (other-lib (target-other-lib-modules)))
315    (require-modules env-modules)
316    (update-modules env-modules force-compile)
317    (compile-modules (target-level-1-modules)  force-compile)
318    (update-modules other-lib force-compile)
319    (require-modules other-lib)
320    (require-update-modules *code-modules* force-compile))
321  (compile-modules *aux-modules* force-compile))
322
323
324
325;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
326
327(defun require-env (&optional force-load)
328  (require-modules  (target-env-modules)
329                   force-load))
330
331(defun compile-level-1 (&optional force-compile)
332  (require-env)
333  (compile-modules (target-level-1-modules (backend-name *host-backend*))
334                   force-compile))
335
336
337
338
339
340(defun compile-lib (&optional force-compile)
341  (compile-modules (target-lib-modules)
342                   force-compile))
343
344(defun compile-code (&optional force-compile)
345  (compile-modules *code-modules* force-compile))
346
347
348;Compile but don't load
349
350(defun xcompile-ccl (&optional force)
351  (compile-modules 'nxenv force)
352  (compile-modules *compiler-modules* force)
353  (compile-modules (target-compiler-modules) force)
354  (compile-modules (target-xdev-modules) force)
355  (compile-modules (target-xload-modules)  force)
356  (compile-modules (target-env-modules) force)
357  (compile-modules (target-level-1-modules) force)
358  (compile-modules (target-other-lib-modules) force)
359  (compile-modules *code-modules* force)
360  (compile-modules *aux-modules* force))
361
362(defun require-update-modules (modules &optional force-compile)
363  (if (not (listp modules)) (setq modules (list modules)))
364  (in-development-mode
365    (dolist (module modules)
366    (require-modules module)
367    (update-modules module force-compile))))
368
369(defun compile-level-1 (&optional force-compile)
370  (compile-modules (target-level-1-modules (backend-name *host-backend*))
371                   force-compile))
372
373
374
375 
376
377(defun target-xcompile-ccl (target &optional force)
378  (let* ((backend (or (find-backend target) *target-backend*))
379         (arch (backend-target-arch-name backend))
380         (*defstruct-share-accessor-functions* nil))
381    (target-compile-modules 'nxenv target force)
382    (target-compile-modules *compiler-modules* target force)
383    (target-compile-modules (target-compiler-modules arch) target force)
384    (target-compile-modules (target-level-1-modules target) target force)
385    (target-compile-modules (target-lib-modules target) target force)
386    (target-compile-modules *aux-modules* target force)
387    (target-compile-modules *code-modules* target force)
388    (target-compile-modules (target-xdev-modules arch) target force)))
389
390(defun cross-compile-ccl (target &optional force)
391  (with-cross-compilation-target (target)
392    (let* ((*target-backend* (find-backend target)))
393      (target-xcompile-ccl target force))))
394
395
396(defun require-module (module force-load)
397  (multiple-value-bind (fasl source) (find-module module)
398      (setq source (car source))
399      (if (if fasl (probe-file fasl))
400        (if force-load
401          (progn
402            (load fasl)
403            (provide module))
404          (require module fasl))
405        (if (probe-file source)
406          (progn
407            (if fasl (format t "~&Can't find ~S so requiring ~S instead"
408                             fasl source))
409            (if force-load
410              (progn
411                (load source)
412                (provide module))
413              (require module source)))
414          (error "Can't find ~S or ~S" fasl source)))))
415
416(defun require-modules (modules &optional force-load)
417  (if (not (listp modules)) (setq modules (list modules)))
418  (let ((*package* (find-package :ccl)))
419    (dolist (m modules t)
420      (require-module m force-load))))
421
422
423(defun target-xcompile-level-1 (target &optional force)
424  (target-compile-modules (target-level-1-modules target) target force))
425
426(defun standard-boot-image-name (&optional (target (backend-name *host-backend*)))
427  (ecase target
428    (:darwinppc32 "ppc-boot.image")
429    (:linuxppc32 "ppc-boot")
430    (:darwinppc64 "ppc-boot64.image")
431    (:linuxppc64 "ppc-boot64")
432    (:darwinx8632 "x86-boot32.image")
433    (:linuxx8664 "x86-boot64")
434    (:freebsdx8664 "fx86-boot64")
435    (:darwinx8664 "x86-boot64.image")))
436
437(defun standard-kernel-name (&optional (target (backend-name *host-backend*)))
438  (ecase target
439    (:darwinppc32 "dppccl")
440    (:linuxppc32 "ppccl")
441    (:darwinppc64 "dppccl64")
442    (:darwinx8632 "dx86cl")
443    (:linuxppc64 "ppccl64")
444    (:linuxx8664 "lx86cl64")
445    (:freebsdx8664 "fx86cl64")
446    (:darwinx8664 "dx86cl64")))
447
448(defun standard-image-name (&optional (target (backend-name *host-backend*)))
449  (ecase target
450    (:darwinppc32 "dppccl.image")
451    (:linuxppc32 "PPCCL")
452    (:darwinppc64 "dppccl64.image")
453    (:linuxppc64 "PPCCL64")
454    (:darwinx8632 "dx86cl.image")
455    (:linuxx8664 "LX86CL64")
456    (:freebsdx8664 "FX86CL64")
457    (:darwinx8664 "dx86cl64.image")))
458
459(defun kernel-build-directory (&optional (target (backend-name *host-backend*)))
460  (ecase target
461    (:darwinppc32 "darwinppc")
462    (:linuxppc32 "linuxppc")
463    (:darwinppc64 "darwinppc64")
464    (:linuxppc64 "linuxppc64")
465    (:darwinx8632 "darwinx8632")
466    (:linuxx8664 "linuxx8664")
467    (:freebsdx8664 "freebsdx8664")
468    (:darwinx8664 "darwinx8664")))
469
470(defun rebuild-ccl (&key full clean kernel force (reload t) exit reload-arguments verbose)
471  (when full
472    (setq clean t kernel t reload t))
473  (let* ((cd (current-directory)))
474    (unwind-protect
475         (progn
476           (setf (current-directory) "ccl:")
477           (when clean
478             (dolist (f (directory
479                         (merge-pathnames
480                          (make-pathname :name :wild
481                                         :type (pathname-type *.fasl-pathname*))
482                          "ccl:**;")))
483               (delete-file f)))
484           (when kernel
485             (when (or clean force)
486               ;; Do a "make -k clean".
487               (run-program "make"
488                            (list "-k"
489                                  "-C"
490                                  (format nil "lisp-kernel/~a"
491                                          (kernel-build-directory))
492                                  "clean")))
493             (format t "~&;Building lisp-kernel ...")
494             (with-output-to-string (s)
495                                    (multiple-value-bind
496                                        (status exit-code)
497                                        (external-process-status 
498                                         (run-program "make"
499                                                      (list "-k" "-C" 
500                                                            (format nil "lisp-kernel/~a"
501                                                                    (kernel-build-directory))
502                                                            "-j"
503                                                           
504                                                            (format nil "~d" (1+ (cpu-count))))
505                                                      :output s
506                                                      :error s))
507                                      (if (and (eq :exited status) (zerop exit-code))
508                                        (progn
509                                          (format t "~&;Kernel built successfully.")
510                                          (when verbose
511                                            (format t "~&;kernel build output:~%~a"
512                                                    (get-output-stream-string s)))
513                                          (sleep 1))
514                                        (error "Error(s) during kernel compilation.~%~a"
515                                               (get-output-stream-string s))))))
516           (compile-ccl (not (null force)))
517           (if force (xload-level-0 :force) (xload-level-0))
518           (when reload
519             (with-input-from-string (cmd (format nil
520                                                  "(save-application ~s)"
521                                                  (standard-image-name)))
522               (with-output-to-string (output)
523                                      (multiple-value-bind (status exit-code)
524                                          (external-process-status
525                                           (run-program
526                                            (format nil "./~a" (standard-kernel-name))
527                                            (list* "--image-name" (standard-boot-image-name)
528                                                   reload-arguments)
529                                            :input cmd
530                                            :output output
531                                            :error output))
532                                        (if (and (eq status :exited)
533                                                 (eql exit-code 0))
534                                          (progn
535                                            (format t "~&;Wrote heap image: ~s"
536                                                    (truename (format nil "ccl:~a"
537                                                                      (standard-image-name))))
538                                            (when verbose
539                                              (format t "~&;Reload heap image output:~%~a"
540                                                      (get-output-stream-string output))))
541                                          (error "Errors (~s ~s) reloading boot image:~&~a"
542                                                 status exit-code
543                                                 (get-output-stream-string output)))))))
544           (when exit
545             (quit)))
546      (setf (current-directory) cd))))
547                                                 
548               
549(defun create-interfaces (dirname &key target populate-arg)
550  (let* ((backend (if target (find-backend target) *target-backend*))
551         (*default-pathname-defaults* nil)
552         (ftd (backend-target-foreign-type-data backend))
553         (d (use-interface-dir dirname ftd))
554         (populate (merge-pathnames "C/populate.sh"
555                                    (merge-pathnames
556                                     (interface-dir-subdir d)
557                                     (ftd-interface-db-directory ftd))))
558         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
559         (args (list "-c"
560                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
561                             (native-translated-namestring cdir)
562                             (native-translated-namestring populate)
563                             populate-arg))))
564    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
565    (force-output t)
566    (multiple-value-bind (status exit-code)
567        (external-process-status
568         (run-program "/bin/sh" args :output t))
569      (if (and (eq status :exited)
570               (eql exit-code 0))
571        (let* ((f 'parse-standard-ffi-files))
572          (require "PARSE-FFI")
573          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
574          (funcall f dirname target)
575          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
576          (funcall f dirname target))))))
Note: See TracBrowser for help on using the repository browser.