worldload.lisp 6.82 KB
Newer Older
ram's avatar
ram committed
1
2
3
;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
;;;
;;; **********************************************************************
4
5
6
7
8
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
9
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.73 1994/02/11 15:20:07 ram Exp $
10
;;;
ram's avatar
ram committed
11
12
13
14
;;; **********************************************************************
;;;
;;; This file loads the parts of the system that aren't cold loaded and saves
;;; the resulting core image.  It writes "lisp.core" in the DEFAULT-DIRECTORY.
15

ram's avatar
ram committed
16
17
18
19
20
;;; Make sure the core will start up in the user package.
(lisp::assert-user-package)

(in-package "LISP")

ram's avatar
ram committed
21
22
23
24
25
26
;;; Get some data on this core.
;;;
(write-string "What is the current lisp-implementation-version? ")
(force-output)
(set '*lisp-implementation-version* (read-line))

27
;;; Load the rest of the reader (may be byte-compiled.)
28
29
(maybe-byte-load "target:code/sharpm")
(maybe-byte-load "target:code/backq")
30
31
(setq std-lisp-readtable (copy-readtable *readtable*))

32
33
34
(maybe-byte-load "target:code/extensions")
(maybe-byte-load "target:code/defmacro")
(maybe-byte-load "target:code/sysmacs")
35

36
;;; Define a bunch of search lists relative to target:
ram's avatar
ram committed
37
;;;
38
39
(setf (ext:search-list "code:") '("target:code/"))
(setf (ext:search-list "c:") '("target:compiler/"))
40
41
42
(setf (ext:search-list "vm:")
      '(#+pmax "c:mips/"
        #+sparc "c:sparc/"
wlott's avatar
wlott committed
43
	#+rt "c:rt/"
wlott's avatar
wlott committed
44
45
	#+hppa "c:hppa/"
	#+x86 "c:x86/"
hallgren's avatar
hallgren committed
46
	#+alpha "c:alpha/"
47
48
	"c:generic/"))
(setf (ext:search-list "assem:")
49
50
51
52
53
      '(#+pmax "target:assembly/mips/"
	#+sparc "target:assembly/sparc/"
	#+rt "target:assembly/rt/"
	#+hppa "target:assembly/hppa/"
	#+x86 "target:assembly/x86/"
hallgren's avatar
hallgren committed
54
	#+alpha "target:assembly/alpha/"
55
56
57
58
59
	"target:assembly/"))
(setf (ext:search-list "hem:") '("target:hemlock/"))
(setf (ext:search-list "clx:") '("target:clx/"))
(setf (ext:search-list "pcl:") '("target:pcl/"))
(setf (ext:search-list "tools:") '("target:tools/"))
60
61

;;; Make sure the package structure is correct.
ram's avatar
ram committed
62
;;;
63
(maybe-byte-load "code:exports")
64
65

;;; Load random code sources.
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
(maybe-byte-load "code:format-time")
(maybe-byte-load "code:parse-time")
#-gengc (maybe-byte-load "code:purify")
(maybe-byte-load "code:commandline")
(maybe-byte-load "code:sort")
(maybe-byte-load "code:time")
(maybe-byte-load "code:tty-inspect")
(maybe-byte-load "code:describe")
(maybe-byte-load "code:rand")
(maybe-byte-load "code:ntrace")
#-runtime (maybe-byte-load "code:profile")
(maybe-byte-load "code:weak")
(maybe-byte-load "code:final")
(maybe-byte-load "code:sysmacs")
#-gengc (maybe-byte-load "code:run-program")
(maybe-byte-load "code:query")
(maybe-byte-load "code:loop")
#-runtime (maybe-byte-load "code:internet")
#-runtime (maybe-byte-load "code:wire")
#-runtime (maybe-byte-load "code:remote")
(maybe-byte-load "code:foreign")
(maybe-byte-load "code:setf-funs")
(maybe-byte-load "code:module")
#-(or gengc runtime) (maybe-byte-load "code:room")
91

ram's avatar
ram committed
92
;;; Overwrite some cold-loaded stuff with byte-compiled versions, if any.
93
94
95
96
97
98
99
100
101
102
#-gengc
(progn
  (byte-load-over "target:code/debug")
  (byte-load-over "target:code/error")
  (maybe-byte-load "target:code/pprint" nil)
  (maybe-byte-load "target:code/format" nil)
  (maybe-byte-load "target:code/reader" nil)
  (maybe-byte-load "target:code/pathname" nil)
  (maybe-byte-load "target:code/filesys" nil)
  (maybe-byte-load "target:code/macros" nil))
ram's avatar
ram committed
103

104
(defvar *old-ie*)
ram's avatar
ram committed
105

106
(setq *old-ie* (car *info-environment*))
107
108
109
110
111
(setq *info-environment*
      (list* (make-info-environment)
	     (compact-info-environment (first *info-environment*)
				       :name "Kernel")
	     (rest *info-environment*)))
112
(lisp::shrink-vector (c::volatile-info-env-table *old-ie*) 0)
113
114
(setq *old-ie* nil)

115
116
117
(purify :root-structures
	`(lisp::%top-level extensions:save-lisp ,lisp::fop-codes))

118
;;; Load the compiler.
119
#-(or no-compiler runtime)
120
(progn
121
  (maybe-byte-load "c:loadcom.lisp")
122
  (setq *old-ie* (car *info-environment*))
123
124
125
126
127
  (setq *info-environment*
	(list* (make-info-environment)
	       (compact-info-environment (first *info-environment*)
					 :name "Compiler")
	       (rest *info-environment*)))
128
  (lisp::shrink-vector (c::volatile-info-env-table *old-ie*) 0)
129

130
  (maybe-byte-load "c:loadbackend.lisp")
131
132
133
  ;; If we want a small core, blow away the meta-compile time VOP info.
  #+small (setf (c::backend-parsed-vops c:*backend*)
		(make-hash-table :test #'eq))
134
135

  (setq *old-ie* (car *info-environment*))
136
137
138
139
  (setq *info-environment*
	(list* (make-info-environment)
	       (compact-info-environment
		(first *info-environment*)
wlott's avatar
typo    
wlott committed
140
		:name
141
142
		(concatenate 'string (c:backend-name c:*backend*) " backend"))
	       (rest *info-environment*)))
ram's avatar
ram committed
143

144
  (lisp::shrink-vector (c::volatile-info-env-table *old-ie*) 0)
145
146
147
  (setq *old-ie* nil))

(purify :root-structures '(compile-file)))
148

149
150
151
152
;;; The pretty printer is part of the kernel core, but we can't turn in on
;;; until after the compiler is loaded because it compiles some lambdas
;;; to help with the dispatching.
;;; 
153
#-(or no-pp runtime)
wlott's avatar
wlott committed
154
(pp::pprint-init)
155

ram's avatar
ram committed
156
157
;;; CLX.
;;;
158
159
#-(or no-clx runtime)
(maybe-byte-load "clx:clx-library")
ram's avatar
ram committed
160
161
162

;;; Hemlock.
;;;
163
164
#-(or no-hemlock runtime)
(maybe-byte-load "target:hemlock/hemlock-library")
ram's avatar
ram committed
165
166
167

;;; PCL.
;;;
168
169
#-(or no-pcl runtime) (maybe-byte-load "pcl:pclload")
; #+(and no-clm (not (or no-pcl no-clx))) (maybe-byte-load "code:inspect")
ram's avatar
ram committed
170

171
172
;;; CLM.
;;;
173
174
#-(or no-clm runtime)
(maybe-byte-load "target:interface/clm-library")
175

176
177
(defvar *target-sl*)
(setq *target-sl* (search-list "target:"))
178

179
;;; Don't include the search lists used for loading in the resultant core.
ram's avatar
ram committed
180
;;;
181
(lisp::clear-all-search-lists)
182
183

;;; Set up a default for modules and target:
184
185
;;; 
(setf (search-list "modules:") '("./"))
186
(setf (search-list "target:") *target-sl*)
ram's avatar
ram committed
187

188
;; set up the initial info environment.
189
(setq *old-ie* (car *info-environment*))
190
191
192
193
194
(setq *info-environment*
      (list* (make-info-environment :name "Working")
	     (compact-info-environment (first *info-environment*)
				       :name "Auxiliary")
	     (rest *info-environment*)))
195
(lisp::shrink-vector (c::volatile-info-env-table *old-ie*) 0)
196
(setq *old-ie* nil)
197

ram's avatar
ram committed
198
199
;;; Okay, build the thing!
;;;
200
(progn
201
202
  ;; We want to be in the USER package when the command line switches run.
  (in-package "USER")
203
  ;; Clean random top-level specials.
204
205
206
207
208
209
210
211
212
213
  (setq - nil)
  (setq + nil)
  (setq * nil)
  (setq / nil)
  (setq ++ nil)
  (setq ** nil)
  (setq // nil)
  (setq +++ nil)
  (setq *** nil)
  (setq /// nil)
214
215
216
217
  ;; 
  ;; Enable the garbage collector.  But first fake it into thinking that
  ;; we don't need to garbage collect.  The save-lisp is going to call purify
  ;; so any garbage will be collected then.
218
219
  #-gengc (setf *need-to-collect-garbage* nil)
  #-gengc (gc-on)
220
221
  ;;
  ;; Save the lisp.
222
  (save-lisp "lisp.core" :root-structures
223
	     `(ed #-(or runtime no-hemlock) ,hi::*global-command-table*)))