Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
5bfd87ac
Commit
5bfd87ac
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial MIPS version.
parent
2b511924
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/save.lisp
+122
-93
122 additions, 93 deletions
code/save.lisp
with
122 additions
and
93 deletions
code/save.lisp
+
122
−
93
View file @
5bfd87ac
...
@@ -8,107 +8,136 @@
...
@@ -8,107 +8,136 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
;;; Spice Lisp routines to suspend a process and create a core file.
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.1.1.1 1990/06/17 02:08:50 wlott Exp $
;;;
;;;
;;; Written David B. McDonald.
;;; Dump the current lisp image into a core file. All the real work is done
;;; be C.
;;;
;;;
;;;**********************************************************************
;;; Written by William Lott.
;;;
;;;
;;;
;;; To see the format of Spice Lisp core files look at the document
;;; prva:<slisp.docs>core.mss.
(
in-package
"LISP"
)
(
in-package
"LISP"
)
(
in-package
"EXTENSIONS"
)
(
in-package
"EXTENSIONS"
)
(
export
'
(
*environment-list*
))
(
export
'
(
print-herald
save-lisp
*before-save-initializations*
(
defvar
*environment-list*
nil
)
*after-save-initializations*
*environment-list*
*editor-lisp-p*
)
)
(
in-package
"LISP"
)
(
in-package
"LISP"
)
(
defvar
*before-save-initializations*
nil
"This is a list of functions which are called before creating a saved core
image. These functions are executed in the child process which has no ports,
so they cannot do anything that tries to talk to the outside world."
)
(
defvar
*after-save-initializations*
nil
"This is a list of functions which are called when a saved core image starts
up. The system itself should be initialized at this point, but applications
might not be."
)
(
proclaim
'
(
special
*task-self*
))
(
defvar
*environment-list*
nil
"An alist mapping environment variables (as keywords) to either values"
)
(
def
constant
save-block-size
(
*
64
1024
)
(
def
var
*editor-lisp-p*
nil
"
Amount to write for each call to write. This is due to RFS limitations
."
)
"
This is true if and only if the lisp was started with the -edit switch
."
)
;;; Filled in by the startup code.
(
defvar
lisp-environment-list
)
(
defvar
lisp-environment-list
)
(
defvar
original-lisp-environment
)
;;;; Global state:
(
def-c-routine
"save"
(
boolean
)
(
file
(
pointer
simple-string
)))
(
defun
save
(
file
)
"Save the current lisp core image in a core file. When it returns in
the current process, the number of bytes written is returned.
(
defun
save-lisp
(
core-file-name
&key
When the saved core image is resumed, Nil is returned."
(
purify
t
)
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
root-structures
())
(
format
t
"~&[Building saved core image: "
)
(
init-function
(
finish-output
)
#'
(
lambda
()
(
let
((
size-to-allocate
(
*
(
current-space-usage
)
2
)))
(
throw
'top-level-catcher
nil
)))
(
declare
(
fixnum
size-to-allocate
))
(
load-init-file
t
)
(
let*
((
addr
(
int-sap
(
gr-call*
mach::vm_allocate
*task-self*
(
print-herald
t
)
0
size-to-allocate
t
)))
(
process-command-line
t
))
(
byte-size
(
%primitive
save
*current-alien-free-pointer*
"Saves a CMU Common Lisp core image in the file of the specified name. The
NIL
addr
)))
following keywords are defined:
(
cond
((
null
byte-size
)
(
mach::vm_deallocate
*task-self*
addr
size-to-allocate
)
:purify
(
error
"Save failed."
))
If true, do a purifying GC which moves all dynamically allocated
((
eq
byte-size
T
)
objects into static space so that they stay pure. This takes somewhat
(
dolist
(
f
*before-save-initializations*
)
(
funcall
f
))
longer than the normal GC which is otherwise done, but GC's will done
(
dolist
(
f
*after-save-initializations*
)
(
funcall
f
))
less often and take less time in the resulting core file.
(
reinit
)
(
setq
original-lisp-environment
lisp-environment-list
)
:root-structures
(
let
((
result
nil
))
This should be a list of the main entry points in any newly loaded
(
dolist
(
ele
lisp-environment-list
systems. This need not be supplied, but locality will be better if it
(
setf
*environment-list*
result
))
is. This is meaningless if :purify is Nil.
(
let
((
=pos
(
position
#\=
(
the
simple-string
ele
))))
;;
:init-function
;; This is dubious since all the strings have an =.
This is a function which is called when the created core file is
;; What if one doesn't? What does that mean?
resumed. The default function simply aborts to the top level
(
when
=pos
read-eval-print loop. If the function returns it will be the value
(
push
(
cons
(
intern
(
string-upcase
(
subseq
ele
0
=pos
))
of Save-Lisp.
*keyword-package*
)
(
subseq
ele
(
1+
=pos
)))
:load-init-file
result
)))))
If true, then look for an init.lisp or init.fasl file when the core
NIL
)
file is resumed.
(
T
(
format
t
"~D bytes.~%"
byte-size
)
:print-herald
(
format
t
"Writing to file: ~A~%"
file
)
If true, print out the lisp system herald when starting."
(
finish-output
)
(
multiple-value-bind
(
fd
err
)
(
mach:unix-creat
file
#o644
)
(
declare
(
ignore
purify
root-structures
))
(
if
(
null
fd
)
#+
nil
(
error
"Failed to open file ~A, unix error: ~A"
(
if
purify
file
(
mach:get-unix-error-msg
err
)))
(
purify
:root-structures
root-structures
)
(
gc
))
(
do
((
left
byte-size
(
-
left
save-block-size
))
(
unless
(
save
(
namestring
core-file-name
))
(
index
0
(
+
index
save-block-size
)))
(
dolist
(
f
*before-save-initializations*
)
(
funcall
f
))
((
<
left
save-block-size
)
(
dolist
(
f
*after-save-initializations*
)
(
funcall
f
))
(
when
(
>
left
0
)
(
reinit
)
(
multiple-value-bind
(
res
err
)
(
dolist
(
ele
lisp-environment-list
)
(
mach:unix-write
fd
addr
index
left
)
(
let
((
=pos
(
position
#\=
(
the
simple-string
ele
))))
(
if
(
null
res
)
(
when
=pos
(
error
"Failed to write file ~A, unix error: ~A"
(
push
(
cons
(
intern
(
string-upcase
(
subseq
ele
0
=pos
))
file
(
mach:get-unix-error-msg
err
))))))
*keyword-package*
)
(
declare
(
fixnum
left
index
))
(
subseq
ele
(
1+
=pos
)))
(
multiple-value-bind
(
res
err
)
*environment-list*
))))
(
mach:unix-write
fd
addr
index
(
setf
(
search-list
"default:"
)
(
list
(
default-directory
)))
save-block-size
)
(
setf
(
search-list
"path:"
)
(
setup-path-search-list
))
(
if
(
null
res
)
(
when
process-command-line
(
ext::process-command-strings
))
(
error
"Failed to write file ~A, unix error: ~A"
(
setf
*editor-lisp-p*
nil
)
file
(
mach:get-unix-error-msg
err
)))))
(
macrolet
((
find-switch
(
name
)
(
multiple-value-bind
(
res
err
)
(
mach:unix-close
fd
)
`
(
find
,
name
*command-line-switches*
(
if
(
null
res
)
:key
#'
cmd-switch-name
(
error
"Failed to close file ~A, unix error: ~A"
:test
#'
(
lambda
(
x
y
)
file
(
mach:get-unix-error-msg
err
)))))
(
declare
(
simple-string
x
y
))
(
format
t
"done.]~%"
)
(
string-equal
x
y
)))))
(
mach::vm_deallocate
*task-self*
addr
size-to-allocate
)
(
when
(
and
process-command-line
(
find-switch
"edit"
))
(
finish-output
)
(
setf
*editor-lisp-p*
t
))
byte-size
)))))
(
when
(
and
load-init-file
(
not
(
and
process-command-line
(
find-switch
"noinit"
))))
(
defun
current-space-usage
()
(
let*
((
cl-switch
(
find-switch
"init"
))
(
declare
(
optimize
(
speed
3
)
(
safety
0
)))
(
name
(
or
(
and
cl-switch
(
do
((
sum
0
)
(
or
(
cmd-switch-value
cl-switch
)
(
type
0
(
1+
type
)))
(
car
(
cmd-switch-words
cl-switch
))
((
>
type
%last-pointer-type
)
sum
)
"init"
))
(
declare
(
fixnum
type
sum
))
"init"
)))
(
if
(
not
(
or
(
eq
type
%short-+-float-type
)
(
eq
type
%short---float-type
)))
(
load
(
merge-pathnames
name
(
user-homedir-pathname
))
(
multiple-value-bind
(
dyn
stat
ro
)
(
space-usage
type
)
:if-does-not-exist
nil
))))
(
declare
(
fixnum
dyn
stat
ro
))
(
when
print-herald
(
setq
sum
(
+
sum
dyn
stat
ro
))))))
(
print-herald
))
(
when
process-command-line
(
ext::invoke-switch-demons
*command-line-switches*
*command-switch-demons*
))
(
funcall
init-function
)))
(
defun
print-herald
()
(
write-string
"CMU Common Lisp "
)
(
write-line
(
lisp-implementation-version
))
(
write-string
"Hemlock "
)
(
write-string
*hemlock-version*
)
(
write-string
", Compiler "
)
(
write-line
#+
nil
compiler-version
#-
nil
"What compiler?"
)
(
write-line
"Send bug reports and questions to Gripe."
)
(
values
))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment