~ chicken-core (chicken-5) 43220148b3dfd24d2d15f07a4de8ba88433f36fb
commit 43220148b3dfd24d2d15f07a4de8ba88433f36fb
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Nov 19 19:55:00 2017 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Nov 22 22:21:51 2017 +1300
Move several global identifiers into suitable modules.
We move all "exit"-related stuff to (chicken base), force-finalizers
to (chicken gc) and return-to-host to (chicken platform).
So, we move:
- exit
- emergency-exit
- on-exit
- exit-handler
- implicit-exit-handler
- force-finalizers
- return-to-host
The reason the "exit" stuff moves to (chicken base) and not
(chicken process-context) is because the latter lives in the posix
unit, which means we'd have to link in a large unit in programs that
just want to exit, which is absurd.
Also, exit is not really process _context_ as such, and the cleanup
stuff is so "core" that it doesn't belong in posix.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index c61557ff..883dd6cf 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -207,7 +207,7 @@
(forms '())
(inline-output-file #f)
(type-output-file #f)
- (cleanup-forms '(((##sys#implicit-exit-handler))))
+ (cleanup-forms '(((chicken.base#implicit-exit-handler))))
(profile (or (memq 'profile options)
(memq 'accumulate-profile options)
(memq 'profile-name options)))
diff --git a/c-platform.scm b/c-platform.scm
index 523ad20f..a8a77c7a 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -727,7 +727,7 @@
(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)
(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)
(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)
-(rewrite 'return-to-host 13 0 "C_return_to_host" #t)
+(rewrite 'chicken.platform#return-to-host 13 0 "C_return_to_host" #t)
(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)
(rewrite '##sys#intern-symbol 13 1 "C_string_to_symbol" #t)
(rewrite '##sys#make-symbol 13 1 "C_make_symbol" #t)
diff --git a/chicken.base.import.scm b/chicken.base.import.scm
index 2f9118b3..5bf90d2e 100644
--- a/chicken.base.import.scm
+++ b/chicken.base.import.scm
@@ -32,12 +32,15 @@
(char-name . chicken.base#char-name)
(cplxnum? . chicken.base#cplxnum?)
(current-error-port . chicken.base#current-error-port)
+ (emergency-exit . chicken.base#emergency-exit)
(enable-warnings . chicken.base#enable-warnings)
(equal=? . chicken.base#equal=?)
+ (exit . chicken.base#exit)
(error . chicken.base#error)
(exact-integer? . chicken.base#exact-integer?)
(exact-integer-sqrt . chicken.base#exact-integer-sqrt)
(exact-integer-nth-root . chicken.base#exact-integer-nth-root)
+ (exit-handler . chicken.base#exit-handler)
(finite? . chicken.base#finite?)
(fixnum? . chicken.base#fixnum?)
(flonum? . chicken.base#flonum?)
@@ -46,11 +49,13 @@
(gensym . chicken.base#gensym)
(get-call-chain . chicken.base#get-call-chain)
(getter-with-setter . chicken.base#getter-with-setter)
+ (implicit-exit-handler . chicken.base#implicit-exit-handler)
(infinite? . chicken.base#infinite?)
(make-parameter . chicken.base#make-parameter)
(make-promise . chicken.base#make-promise)
(nan? . chicken.base#nan?)
(notice . chicken.base#notice)
+ (on-exit . chicken.base#on-exit)
(print . chicken.base#print)
(print-call-chain . chicken.base#print-call-chain)
(print* . chicken.base#print*)
diff --git a/chicken.import.scm b/chicken.import.scm
index 153a521b..41b5ace6 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -64,8 +64,8 @@
(exact-integer-sqrt . chicken.base#exact-integer-sqrt)
(exact-integer-nth-root . chicken.base#exact-integer-nth-root)
executable-pathname
- exit
- exit-handler
+ (exit . chicken.base#exit)
+ (exit-handler . chicken.base#exit-handler)
(expand . chicken.syntax#expand)
(feature? . chicken.platform#feature?)
(features . chicken.platform#features)
@@ -78,7 +78,7 @@
flush-output
(foldl . chicken.base#foldl)
(foldr . chicken.base#foldr)
- force-finalizers
+ (force-finalizers . chicken.gc#force-finalizers)
(fx- . chicken.fixnum#fx-)
(fx* . chicken.fixnum#fx*)
(fx/ . chicken.fixnum#fx/)
@@ -111,7 +111,7 @@
(get-line-number . chicken.syntax#get-line-number)
get-output-string
(getter-with-setter . chicken.base#getter-with-setter)
- implicit-exit-handler
+ (implicit-exit-handler . chicken.base#implicit-exit-handler)
(infinite? . chicken.base#infinite?)
input-port-open?
(installation-repository . chicken.platform#installation-repository)
@@ -131,7 +131,7 @@
(most-positive-fixnum . chicken.fixnum#most-positive-fixnum)
(nan? . chicken.base#nan?)
(notice . chicken.base#notice)
- on-exit
+ (on-exit . chicken.base#on-exit)
open-input-string
open-output-string
output-port-open?
@@ -154,7 +154,7 @@
(register-feature! . chicken.platform#register-feature!)
(repository-path . chicken.platform#repository-path)
(require . chicken.load#require)
- return-to-host
+ (return-to-host . chicken.platform#return-to-host)
set-port-name!
(setter . chicken.base#setter)
(signal . chicken.condition#signal)
diff --git a/library.scm b/library.scm
index cd5b8042..44927eef 100644
--- a/library.scm
+++ b/library.scm
@@ -34,7 +34,7 @@
current-print-length setter-tag
##sys#print-exit
##sys#format-here-doc-warning
- exit-in-progress
+ exit-in-progress cleanup-before-exit chicken.base#cleanup-tasks
maximal-string-length find-ratio-between find-ratio
make-complex flonum->ratnum ratnum
+maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient
@@ -580,9 +580,11 @@ EOF
;; alist-ref alist-update alist-update! rassoc atom? butlast chop
;; compress flatten intersperse join list-of? tail? constantly
;; complement compose conjoin disjoin each flip identity o
+
+ on-exit exit exit-handler implicit-exit-handler emergency-exit
)
-(import scheme)
+(import scheme (only chicken when unless))
(define (fixnum? x) (##core#inline "C_fixnump" x))
(define (flonum? x) (##core#inline "C_i_flonump" x))
@@ -678,6 +680,23 @@ EOF
z
(f (##sys#slot lst 0) (loop (##sys#slot lst 1))))))
+;;; Exit:
+
+(define implicit-exit-handler)
+(define exit-handler)
+
+(define chicken.base#cleanup-tasks '())
+
+(define (on-exit thunk)
+ (set! cleanup-tasks (cons thunk chicken.base#cleanup-tasks)))
+
+(define (exit #!optional (code 0))
+ ((exit-handler) code))
+
+(define (emergency-exit #!optional (code 0))
+ (##sys#check-fixnum code 'emergency-exit)
+ (##core#inline "C_exit_runtime" code))
+
) ; chicken.base
(import chicken.base)
@@ -738,7 +757,6 @@ EOF
;;; System routines:
-(define (exit #!optional (code 0)) ((##sys#exit-handler) code))
(define (##sys#debug-mode?) (##core#inline "C_i_debug_modep"))
(define ##sys#warnings-enabled #t)
@@ -776,7 +794,6 @@ EOF
(define (argc+argv) (##sys#values main_argc main_argv))
(define ##sys#make-structure (##core#primitive "C_make_structure"))
(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
-(define return-to-host (##core#primitive "C_return_to_host"))
(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
@@ -4768,51 +4785,46 @@ EOF
(define exit-in-progress #f)
-(define exit-handler
+(define (cleanup-before-exit)
+ (set! exit-in-progress #t)
+ (when (##core#inline "C_i_dump_heap_on_exitp")
+ (##sys#print "\n" #f ##sys#standard-error)
+ (##sys#dump-heap-state))
+ (when (##core#inline "C_i_profilingp")
+ (##core#inline "C_i_dump_statistical_profile"))
+ (let loop ()
+ (let ((tasks chicken.base#cleanup-tasks))
+ (set! chicken.base#cleanup-tasks '())
+ (unless (null? tasks)
+ (for-each (lambda (t) (t)) tasks)
+ (loop))))
+ (when (##sys#debug-mode?)
+ (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error))
+ (when (chicken.gc#force-finalizers)
+ (##sys#force-finalizers)))
+
+(set! chicken.base#exit-handler
(make-parameter
(lambda (#!optional (code 0))
(##sys#check-fixnum code)
(cond (exit-in-progress
(##sys#warn "\"exit\" called while processing on-exit tasks"))
(else
- (##sys#cleanup-before-exit)
+ (cleanup-before-exit)
(##core#inline "C_exit_runtime" code))))))
-(define implicit-exit-handler
+(set! chicken.base#implicit-exit-handler
(make-parameter
(lambda ()
- (##sys#cleanup-before-exit) ) ) )
+ (cleanup-before-exit))))
+
+;; OBSOLETE: remove after bootstrapping
+(define ##sys#implicit-exit-handler chicken.base#implicit-exit-handler)
-(define ##sys#exit-handler exit-handler)
-(define ##sys#implicit-exit-handler implicit-exit-handler)
(define ##sys#reset-handler ; Exposed by chicken.repl
(make-parameter
(lambda ()
- ((##sys#exit-handler) _ex_software))))
-
-(define force-finalizers (make-parameter #t))
-
-(define ##sys#cleanup-tasks '())
-
-(define (##sys#cleanup-before-exit)
- (set! exit-in-progress #t)
- (when (##core#inline "C_i_dump_heap_on_exitp")
- (##sys#print "\n" #f ##sys#standard-error)
- (##sys#dump-heap-state))
- (when (##core#inline "C_i_profilingp")
- (##core#inline "C_i_dump_statistical_profile"))
- (let loop ()
- (let ((tasks ##sys#cleanup-tasks))
- (set! ##sys#cleanup-tasks '())
- (unless (null? tasks)
- (for-each (lambda (t) (t)) tasks)
- (loop))))
- (when (##sys#debug-mode?)
- (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) )
- (when (force-finalizers) (##sys#force-finalizers)) )
-
-(define (on-exit thunk)
- (set! ##sys#cleanup-tasks (cons thunk ##sys#cleanup-tasks)))
+ ((exit-handler) _ex_software))))
;;; Condition handling:
@@ -5688,10 +5700,11 @@ EOF
(module chicken.gc
- (current-gc-milliseconds gc memory-statistics set-finalizer! set-gc-report!)
+ (current-gc-milliseconds gc memory-statistics set-finalizer!
+ set-gc-report! force-finalizers)
(import scheme)
-(import chicken.fixnum chicken.foreign)
+(import chicken.base chicken.fixnum chicken.foreign)
(import (only chicken when unless handle-exceptions))
;;; GC info:
@@ -5784,6 +5797,8 @@ EOF
((procedure? state) (state))
(state (##sys#context-switch state) ) ) ) ))
+(define force-finalizers (make-parameter #t))
+
(define (##sys#force-finalizers)
(let loop ()
(let ([n (##sys#gc)])
@@ -6031,7 +6046,7 @@ EOF
feature? features machine-byte-order machine-type
repository-path installation-repository
register-feature! unregister-feature!
- software-type software-version
+ software-type software-version return-to-host
)
(import scheme)
@@ -6194,6 +6209,9 @@ EOF
(and (memq (->feature-id (##sys#slot ids 0)) ##sys#features)
(loop (##sys#slot ids 1))))))
+(define return-to-host
+ (##core#primitive "C_return_to_host"))
+
) ; chicken.platform
diff --git a/posix-common.scm b/posix-common.scm
index 58342176..d8322ce3 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -201,14 +201,6 @@ EOF
(define ##sys#posix-error posix-error)
-;;; Exit
-
-(define emergency-exit
- (let ((_exit (foreign-lambda void "_exit" int)))
- (lambda (#!optional (code 0))
- (_exit code))))
-
-
;;; File properties
(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
diff --git a/posix.scm b/posix.scm
index 96411355..88bd2b5d 100644
--- a/posix.scm
+++ b/posix.scm
@@ -47,7 +47,7 @@
current-effective-group-id current-effective-user-id
current-effective-user-name current-group-id current-process-id
current-user-id current-user-name directory
- directory? duplicate-fileno emergency-exit fcntl/dupfd fcntl/getfd
+ directory? duplicate-fileno fcntl/dupfd fcntl/getfd
fcntl/getfl fcntl/setfd fcntl/setfl fifo? fifo? file-access-time
file-change-time file-close file-control file-creation-mode
file-execute-access? file-group file-link file-lock
@@ -219,7 +219,7 @@
(change-directory change-directory* current-directory
command-line-arguments argv get-environment-variable
get-environment-variables set-environment-variable!
- unset-environment-variable! emergency-exit exit on-exit
+ unset-environment-variable!
executable-pathname program-name set-root-directory!
current-effective-group-id current-effective-user-id
current-group-id current-process-id current-user-id
diff --git a/profiler.scm b/profiler.scm
index cfc27bdc..3ec52c1d 100644
--- a/profiler.scm
+++ b/profiler.scm
@@ -60,13 +60,13 @@
(if (string? filename)
filename
(string-append "PROFILE." (number->string profile-id))))
- (let ([oldeh (##sys#exit-handler)]
- [oldieh (##sys#implicit-exit-handler)] )
- (##sys#exit-handler
+ (let ((oldeh (exit-handler))
+ (oldieh (implicit-exit-handler)))
+ (exit-handler
(lambda args
(##sys#finish-profile)
(apply oldeh args) ) )
- (##sys#implicit-exit-handler
+ (implicit-exit-handler
(lambda ()
(##sys#finish-profile)
(oldieh) ) ) ) )
diff --git a/stub.scm b/stub.scm
index 7da6774b..066cbf0c 100644
--- a/stub.scm
+++ b/stub.scm
@@ -30,4 +30,6 @@
(uses library eval data-structures port extras)
(not safe) )
+(import chicken.platform)
+
(let loop () (return-to-host) (loop))
diff --git a/tests/embedded2.scm b/tests/embedded2.scm
index 429517a1..19be900a 100644
--- a/tests/embedded2.scm
+++ b/tests/embedded2.scm
@@ -1,4 +1,4 @@
-(import chicken.gc chicken.pretty-print)
+(import chicken.platform chicken.gc chicken.pretty-print)
#>
#include <assert.h>
diff --git a/tests/embedded4.scm b/tests/embedded4.scm
index 399f698c..55cdb440 100644
--- a/tests/embedded4.scm
+++ b/tests/embedded4.scm
@@ -1,6 +1,6 @@
;;; x.scm
-(import (chicken gc))
+(import (chicken gc) (chicken platform))
(define (bar x) (gc) (* x x))
diff --git a/tests/user-pass-tests.scm b/tests/user-pass-tests.scm
index 0ef5f931..a8710a02 100644
--- a/tests/user-pass-tests.scm
+++ b/tests/user-pass-tests.scm
@@ -1,6 +1,7 @@
;;; Test user compilation passes
-(import (chicken compiler user-pass)
+(import (chicken base)
+ (chicken compiler user-pass)
(chicken io)
(chicken pretty-print))
diff --git a/types.db b/types.db
index 321e8ef9..8aaaf5db 100644
--- a/types.db
+++ b/types.db
@@ -944,6 +944,14 @@
((* (or symbol char eof null undefined)) (scheme#eq? #(1) #(2)))
((number number) (scheme#= #(1) #(2))))
+(chicken.base#emergency-exit (procedure chicken.base#emergency-exit (#!optional fixnum) noreturn))
+(chicken.base#on-exit (#(procedure #:clean #:enforce) chicken.base#on-exit ((procedure () . *)) undefined))
+(chicken.base#implicit-exit-handler
+ (#(procedure #:clean #:enforce) chicken.base#implicit-exit-handler (#!optional (procedure () . *)) procedure))
+
+(chicken.base#exit (procedure chicken.base#exit (#!optional fixnum) noreturn))
+(chicken.base#exit-handler (#(procedure #:clean #:enforce) chicken.base#exit-handler (#!optional (procedure (fixnum) . *)) procedure))
+
(chicken.base#gensym (#(procedure #:clean) chicken.base#gensym (#!optional (or string symbol)) symbol))
(chicken.base#char-name (#(procedure #:clean #:enforce) chicken.base#char-name ((or char symbol) #!optional char) *)) ;XXX -> (or char symbol) ?
@@ -1113,14 +1121,11 @@
(##sys#debug-mode? (procedure ##sys#debug-mode? () boolean)
(() (##core#inline "C_i_debug_modep")))
(executable-pathname (#(procedure #:pure) executable-pathname () (or string false)))
-(exit (procedure exit (#!optional fixnum) noreturn))
-(exit-handler (#(procedure #:clean #:enforce) exit-handler (#!optional (procedure (fixnum) . *)) procedure))
(file-exists? (#(procedure #:clean #:enforce) file-exists? (string) (or false string)))
(directory-exists? (#(procedure #:clean #:enforce) directory-exists? (string) (or false string)))
(flush-output (#(procedure #:enforce) flush-output (#!optional output-port) undefined))
-(force-finalizers (procedure force-finalizers () undefined))
;; flonum
@@ -1299,6 +1304,7 @@
(chicken.platform#machine-type (#(procedure #:pure) chicken.platform#machine-type () symbol))
(chicken.platform#repository-path (#(procedure #:clean) chicken.platform#repository-path (#!optional *) *))
(chicken.platform#installation-repository (#(procedure #:clean) chicken.platform#installation-repository (#!optional *) *))
+(chicken.platform#return-to-host (procedure chicken.platform#return-to-host () . *))
;; plist
@@ -1312,16 +1318,12 @@
(chicken.plist#symbol-plist (#(procedure #:clean #:enforce) chicken.plist#symbol-plist (symbol) list)
((symbol) (##sys#slot #(1) '2)))
-(implicit-exit-handler
- (#(procedure #:clean #:enforce) implicit-exit-handler (#!optional (procedure () . *)) procedure))
-
(keyword-style (#(procedure #:clean) keyword-style (#!optional symbol) symbol))
(chicken.flonum#maximum-flonum float)
(chicken.flonum#minimum-flonum float)
(chicken.fixnum#most-negative-fixnum fixnum)
(chicken.fixnum#most-positive-fixnum fixnum)
-(on-exit (#(procedure #:clean #:enforce) on-exit ((procedure () . *)) undefined))
(open-input-string (#(procedure #:clean #:enforce) open-input-string (string #!rest) input-port))
(open-output-string (#(procedure #:clean) open-output-string (#!rest) output-port))
(parentheses-synonyms (#(procedure #:clean) parentheses-synonyms (#!optional *) *))
@@ -1338,11 +1340,11 @@
(program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string))
-(return-to-host (procedure return-to-host () . *))
;; gc
(chicken.gc#current-gc-milliseconds (#(procedure #:clean) chicken.gc#current-gc-milliseconds () integer))
+(chicken.gc#force-finalizers (procedure chicken.gc#force-finalizers () undefined))
(chicken.gc#gc (#(procedure #:clean) chicken.gc#gc (#!optional *) fixnum))
(chicken.gc#memory-statistics (#(procedure #:clean) chicken.gc#memory-statistics () (vector-of fixnum)))
(chicken.gc#set-finalizer! (#(procedure #:clean #:enforce) chicken.gc#set-finalizer! (* (procedure (*) . *)) *))
@@ -1908,7 +1910,6 @@
;; posix
-(chicken.posix#emergency-exit (procedure chicken.posix#emergency-exit (#!optional fixnum) noreturn))
(chicken.posix#call-with-input-pipe (#(procedure #:enforce) chicken.posix#call-with-input-pipe (string (procedure (input-port) . *) #!optional symbol) . *))
(chicken.posix#call-with-output-pipe (#(procedure #:enforce) chicken.posix#call-with-output-pipe (string (procedure (input-port) . *) #!optional symbol) . *))
(chicken.posix#change-directory (#(procedure #:clean #:enforce) chicken.posix#change-directory (string) string))
Trap