From c9d7d96a72e363989bf43b61f13828daacfe1320 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 19 Nov 2017 19:55:00 +0100 Subject: [PATCH] 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. --- batch-driver.scm | 2 +- c-platform.scm | 2 +- chicken.base.import.scm | 5 +++ chicken.import.scm | 12 +++---- library.scm | 91 +++++++++++++++++++++++++++-------------------- posix-common.scm | 8 ----- posix.scm | 4 +-- profiler.scm | 8 ++--- stub.scm | 2 ++ tests/embedded2.scm | 2 +- tests/embedded4.scm | 2 +- tests/user-pass-tests.scm | 3 +- types.db | 19 +++++----- 13 files changed, 88 insertions(+), 72 deletions(-) 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..4f19d6bd 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,22 @@ 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 +756,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 +793,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 +4784,45 @@ 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 +5698,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 +5795,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 +6044,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 +6207,8 @@ 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..202f67ef 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 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..01208eaf 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)) -- 2.11.0