Implement environment per thread via process-resource/thread-fluids.
This commit is contained in:
mainzelm
parent
c733047ff0
commit
4aa561b569
|
|
@ -136,7 +136,7 @@ SCSHOBJS = \
|
|||
scsh/regexp/libregex.a
|
||||
|
||||
SCSH_INITIALIZERS = s48_init_syslog s48_init_userinfo s48_init_sighandlers \
|
||||
s48_init_re_low
|
||||
s48_init_re_low s48_init_syscalls2
|
||||
|
||||
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
|
||||
|
||||
|
|
|
|||
401
scsh/scsh.scm
401
scsh/scsh.scm
|
|
@ -51,7 +51,6 @@
|
|||
(really-fork/pipe+ fork conns maybe-thunk))
|
||||
|
||||
;;; Common code.
|
||||
;; JMG: this should spawn a thread to prevent deadlocking the vm
|
||||
(define (really-fork/pipe+ forker conns maybe-thunk)
|
||||
(let* ((pipes (map (lambda (conn) (call-with-values pipe cons))
|
||||
conns))
|
||||
|
|
@ -113,97 +112,224 @@
|
|||
|
||||
|
||||
|
||||
;;; Environment stuff
|
||||
|
||||
;;; Should be moved to somewhere else
|
||||
(define (with-lock lock thunk)
|
||||
(with-handler (lambda (condition more)
|
||||
(release-lock lock)
|
||||
(more))
|
||||
(lambda ()
|
||||
(obtain-lock lock)
|
||||
(let ((result (thunk)))
|
||||
(release-lock lock)
|
||||
result))))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; A resource is a part of the process state for which every thread
|
||||
;;; has its own value
|
||||
;;; uses the procedures:
|
||||
;;; (process-read-resource (-> 'X))
|
||||
;;; (process-set-resource ('X -> unspec))
|
||||
;;; (resource-eq? ('X 'X -> bool))
|
||||
|
||||
;;; defines the procedures:
|
||||
;;; (initialize-resource (-> unspec)) ; call on startup
|
||||
;;; (with-resource* ((-> 'X) -> 'X))
|
||||
;;; (with-resource-aligned* ((-> 'X) -> 'X))
|
||||
;;; (thread-read-resource (-> 'X))
|
||||
;;; (thread-set-resource ('X -> unspec))
|
||||
|
||||
(define-syntax make-process-resource
|
||||
(syntax-rules ()
|
||||
((make-process-resource
|
||||
initialize-resource
|
||||
thread-read-resource thread-set-resource! thread-change-resource
|
||||
with-resource* with-resource-aligned*
|
||||
process-read-resource process-set-resource resource-eq?)
|
||||
(begin
|
||||
(define *resource-cache* 'uninitialized)
|
||||
(define resource-lock 'uninitialized)
|
||||
|
||||
(define (initialize-resource)
|
||||
(set! *resource-cache* (process-read-resource))
|
||||
(set! $resource ;;; TODO The old thread-fluid will remain
|
||||
(make-thread-fluid
|
||||
(process-read-resource)))
|
||||
(set! resource-lock (make-lock)))
|
||||
|
||||
(define (cache-value)
|
||||
*resource-cache*)
|
||||
|
||||
;;; Actually do the syscall and update the cache
|
||||
;;; assumes the resource lock obtained
|
||||
(define (change-and-cache dir)
|
||||
(process-set-resource dir)
|
||||
(set! *resource-cache* (process-read-resource)))
|
||||
|
||||
;;; Dynamic-wind is not the right thing to take care of the lock;
|
||||
;;; it would release the lock on every context switch.
|
||||
;;; With-lock releases the lock on a condition, using call/cc will
|
||||
;;; skrew things up
|
||||
|
||||
;;; The thread-specific resource: A thread fluid
|
||||
|
||||
(define $resource 'emtpy-resource-value)
|
||||
|
||||
(define (thread-read-resource) (thread-fluid $resource))
|
||||
(define (thread-set-resource! dir) (set-thread-fluid! $resource dir))
|
||||
(define (let-resource dir thunk)
|
||||
(let-thread-fluid $resource dir thunk))
|
||||
|
||||
(define (with-resource* dir thunk)
|
||||
(let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!!
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(change-and-cache dir)
|
||||
(set! changed-dir (cache-value))))
|
||||
(let-resource changed-dir thunk)))
|
||||
|
||||
;; Align the value of the Unix resource with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the resource lock.
|
||||
|
||||
(define (align-resource!)
|
||||
(let ((dir (thread-read-resource)))
|
||||
(if (not (resource-eq? dir (cache-value)))
|
||||
(change-and-cache dir))))
|
||||
|
||||
(define (thread-change-resource dir)
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(change-and-cache dir)
|
||||
(thread-set-resource! (cache-value)))))
|
||||
|
||||
;;; For thunks that don't raise exceptions or throw to continuations,
|
||||
;;; this is overkill & probably a little heavyweight for frequent use.
|
||||
;;; But it is general.
|
||||
;;;
|
||||
;;; A less-general, more lightweight hack could be done just for
|
||||
;;; syscalls. We could probably dump the DYNAMIC-WINDs and build the
|
||||
;;; rest of the pattern into one of the syscall-defining macros, or
|
||||
;;; something.
|
||||
;;; Olin adds the following: the efficient way to do things is not
|
||||
;;; with a dynamic wind or a lock. Just turn off interrupts, sync the
|
||||
;;; resource, do the syscall, turn them back on.
|
||||
|
||||
(define (with-resource-aligned* thunk)
|
||||
(dynamic-wind (lambda ()
|
||||
(with-lock resource-lock
|
||||
align-resource!))
|
||||
thunk
|
||||
values))
|
||||
|
||||
;;; example syscall
|
||||
;;; (define (exported-delete-file fname)
|
||||
;;;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
|
||||
(define resource-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-resource))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; working directory per thread
|
||||
(make-process-resource
|
||||
initialize-cwd cwd thread-set-cwd! chdir with-cwd* with-cwd-aligned*
|
||||
process-cwd process-chdir string=?)
|
||||
|
||||
(initialize-cwd)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; umask per thread
|
||||
|
||||
(make-process-resource
|
||||
initialize-umask umask thread-set-umask set-umask
|
||||
with-umask* with-umask-aligned*
|
||||
process-umask set-process-umask =)
|
||||
|
||||
(initialize-umask)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-record env
|
||||
c-struct ; An alien -- pointer to an envvec struct
|
||||
;;; Environment per thread
|
||||
|
||||
(define-record env
|
||||
envvec
|
||||
alist) ; Corresponding alist
|
||||
|
||||
;;; Once more, Olin's define-record is not sufficient
|
||||
(define (make-environ c-struct alist)
|
||||
(let ((env (make-env c-struct alist)))
|
||||
(add-finalizer! env env-finalizer)
|
||||
env))
|
||||
(define-record-discloser type/env
|
||||
(lambda (e)
|
||||
(list 'env (env:envvec e) (env:alist e))))
|
||||
|
||||
(define (env-finalizer env)
|
||||
(display "freeing env")
|
||||
(%free-env (env:c-struct env)))
|
||||
(define (env=? e1 e2)
|
||||
(and (env:envvec e1)
|
||||
(eq? (env:envvec e1)
|
||||
(env:envvec e2))))
|
||||
|
||||
(define env-lock (make-lock))
|
||||
(define-record envvec
|
||||
environ ;; char**
|
||||
)
|
||||
|
||||
(define current-process-env #f)
|
||||
(define $current-env #f)
|
||||
(define (install-env)
|
||||
(set! current-process-env
|
||||
(make-threads-env (environ-env->alist)))
|
||||
(set! $current-env (make-fluid current-process-env))
|
||||
(%align-env (env:c-struct (current-env))))
|
||||
|
||||
(define (make-threads-env alist)
|
||||
(make-environ (alist->envvec alist) alist))
|
||||
(define (add-envvec-finalizer! envvec)
|
||||
(add-finalizer! envvec envvec-finalizer))
|
||||
|
||||
(define (current-env) (fluid $current-env))
|
||||
(define-exported-binding "envvec-record-type" type/envvec)
|
||||
(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!)
|
||||
|
||||
(define (align-env!)
|
||||
(let ((current-env-val (current-env)))
|
||||
(if (not (eq? current-env-val current-process-env))
|
||||
(begin (%align-env (env:c-struct current-env-val))
|
||||
(set! current-process-env current-env-val)))))
|
||||
(define (envvec-finalizer envvec)
|
||||
(%free-env envvec))
|
||||
|
||||
(define (with-env-aligned* thunk)
|
||||
(dynamic-wind (lambda ()
|
||||
(with-lock env-lock
|
||||
align-env!))
|
||||
thunk values))
|
||||
(define (environ**-read)
|
||||
(let ((alist.envvec (environ-env->alist)))
|
||||
(make-env (cdr alist.envvec) (car alist.envvec))))
|
||||
|
||||
(define (with-total-env* alist thunk)
|
||||
(let-fluid $current-env (make-threads-env alist) thunk))
|
||||
(define (environ**-set env)
|
||||
(if (env:envvec env)
|
||||
(%align-env (env:envvec env))
|
||||
(set-env:envvec env (envvec-alist->env (env:alist env)))))
|
||||
|
||||
(define (getenv var)
|
||||
(let* ((env (thread-read-env))
|
||||
(res (assoc var (env:alist env))))
|
||||
(if res (cdr res) res)))
|
||||
|
||||
(define (env->alist)
|
||||
(env:alist (thread-read-env)))
|
||||
|
||||
(define (setenv var val)
|
||||
(let* ((env (thread-read-env))
|
||||
(alist (alist-update
|
||||
var
|
||||
val
|
||||
(fold cons '() (env:alist env)))))
|
||||
(thread-set-env!
|
||||
(make-env
|
||||
#f
|
||||
alist
|
||||
))))
|
||||
|
||||
(define (alist->env alist)
|
||||
(thread-set-env!
|
||||
(make-env
|
||||
#f
|
||||
alist)))
|
||||
|
||||
(define (with-env* alist-delta thunk)
|
||||
(let ((new-env (fold (lambda (key/val alist)
|
||||
(alist-update (car key/val) (cdr key/val) alist))
|
||||
(env->alist)
|
||||
alist-delta)))
|
||||
(let-fluid $current-env (make-threads-env new-env) thunk)))
|
||||
(with-total-env* new-env thunk)))
|
||||
|
||||
;(define (lp) (display (getenv "BLA")) (sleep 2000) (lp))
|
||||
(define (with-total-env* alist thunk)
|
||||
(with-env-internal* (make-env #f alist) thunk))
|
||||
|
||||
(define (env->alist)
|
||||
(with-env-aligned*
|
||||
(lambda ()
|
||||
(environ-env->alist))))
|
||||
|
||||
(define (alist->env alist)
|
||||
(with-env-aligned*
|
||||
(lambda ()
|
||||
(let ((env (current-env)))
|
||||
(envvec-alist->env alist)
|
||||
(set-env:alist env alist)))))
|
||||
|
||||
(define (delete-env name)
|
||||
(let ((env (current-env)))
|
||||
(set-env:alist env (alist-delete name (env:alist env))))
|
||||
(envvec-delete-env name))
|
||||
|
||||
(define (setenv name value)
|
||||
(with-env-aligned*
|
||||
(lambda ()
|
||||
(if value
|
||||
(begin
|
||||
(envvec-setenv name value)
|
||||
(let ((env (current-env)))
|
||||
(set-env:alist env (alist-update name value (env:alist env)))))
|
||||
(delete-env name)))))
|
||||
|
||||
(define (getenv name)
|
||||
(with-env-aligned*
|
||||
(lambda ()
|
||||
(let* ((here (assoc name (env:alist (current-env))))
|
||||
(here (if here (cdr here) here)))
|
||||
(if (not (equal? here (envvec-getenv name)))
|
||||
(error "not equal" here (envvec-getenv name))
|
||||
here)))))
|
||||
|
||||
(make-process-resource install-env thread-read-env thread-set-env!
|
||||
useless-set-env
|
||||
with-env-internal* with-env-aligned*
|
||||
environ**-read environ**-set env=?)
|
||||
|
||||
;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
|
||||
;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
|
||||
|
|
@ -283,126 +409,6 @@
|
|||
#f)) ; AFTER doesn't appear in LIST.
|
||||
(cons elt list)))
|
||||
|
||||
;;; Should be moved to somewhere else
|
||||
(define (with-lock lock thunk)
|
||||
(with-handler (lambda (condition more)
|
||||
(release-lock lock)
|
||||
(more))
|
||||
(lambda ()
|
||||
(obtain-lock lock)
|
||||
(let ((result (thunk)))
|
||||
(release-lock lock)
|
||||
result))))
|
||||
|
||||
|
||||
;;; A resource is a part of the process state for which every thread
|
||||
;;; has its own value
|
||||
(define-syntax make-process-resource
|
||||
(syntax-rules ()
|
||||
((make-process-resource
|
||||
initialize-resource
|
||||
thread-read-resource thread-set-resource with-resource*
|
||||
with-resource-aligned* process-read-resource process-set-resource)
|
||||
(begin
|
||||
(define *resource-cache* 'uninitialized)
|
||||
(define resource-lock 'uninitialized)
|
||||
|
||||
(define (initialize-resource)
|
||||
(set! *resource-cache* (process-read-resource))
|
||||
(set! resource-lock (make-lock)))
|
||||
|
||||
(define (cache-value)
|
||||
*resource-cache*)
|
||||
|
||||
;;; Actually do the syscall and update the cache
|
||||
;;; assumes the resource lock obtained
|
||||
(define (change-and-cache dir)
|
||||
(process-set-resource dir)
|
||||
(set! *resource-cache* (process-read-resource)))
|
||||
|
||||
;;; Dynamic-wind is not the right thing to take care of the lock;
|
||||
;;; it would release the lock on every context switch.
|
||||
;;; With-lock releases the lock on a condition, using call/cc will
|
||||
;;; skrew things up
|
||||
|
||||
;;; The thread-specific resource: A thread fluid
|
||||
|
||||
(define $resource
|
||||
(make-thread-fluid
|
||||
(process-read-resource)))
|
||||
|
||||
(define (thread-read-resource) (thread-fluid $resource))
|
||||
(define (set-resource! dir) (set-thread-fluid! $resource dir))
|
||||
(define (let-resource dir thunk)
|
||||
(let-thread-fluid $resource dir thunk))
|
||||
|
||||
(define (with-resource* dir thunk)
|
||||
(let ((changed-dir #f)) ; TODO 0.5 used to have a dynamic-wind here!!!
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(change-and-cache dir)
|
||||
(set! changed-dir (cache-value))))
|
||||
(let-resource changed-dir thunk)))
|
||||
|
||||
;; Align the value of the Unix resource with scsh's value.
|
||||
;; Since another thread could disalign, this call and
|
||||
;; any ensuring syscall that relies upon it should
|
||||
;; be "glued together" with the resource lock.
|
||||
|
||||
(define (align-resource!)
|
||||
(let ((dir (thread-read-resource)))
|
||||
(if (not (string=? dir (cache-value)))
|
||||
(change-and-cache dir))))
|
||||
|
||||
(define (thread-set-resource dir)
|
||||
(with-lock resource-lock
|
||||
(lambda ()
|
||||
(change-and-cache dir)
|
||||
(set-resource! (cache-value)))))
|
||||
|
||||
;;; For thunks that don't raise exceptions or throw to continuations,
|
||||
;;; this is overkill & probably a little heavyweight for frequent use.
|
||||
;;; But it is general.
|
||||
;;;
|
||||
;;; A less-general, more lightweight hack could be done just for
|
||||
;;; syscalls. We could probably dump the DYNAMIC-WINDs and build the
|
||||
;;; rest of the pattern into one of the syscall-defining macros, or
|
||||
;;; something.
|
||||
;;; Olin adds the following: the efficient way to do things is not
|
||||
;;; with a dynamic wind or a lock. Just turn off interrupts, sync the
|
||||
;;; resource, do the syscall, turn them back on.
|
||||
|
||||
(define (with-resource-aligned* thunk)
|
||||
(dynamic-wind (lambda ()
|
||||
(with-lock resource-lock
|
||||
align-resource!))
|
||||
thunk
|
||||
values))
|
||||
|
||||
;;; example syscall
|
||||
;;; (define (exported-delete-file fname)
|
||||
;;;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
|
||||
(define resource-reinitializer
|
||||
(make-reinitializer initialize-resource))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; working directory per thread
|
||||
(make-process-resource
|
||||
initialize-cwd cwd chdir with-cwd* with-cwd-aligned*
|
||||
process-cwd process-chdir)
|
||||
|
||||
(initialize-cwd)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; umask per thread
|
||||
|
||||
(make-process-resource
|
||||
initialize-umask umask set-umask with-umask* with-umask-aligned*
|
||||
process-umask set-process-umask)
|
||||
|
||||
(initialize-umask)
|
||||
;;; Sugar:
|
||||
|
||||
(define-simple-syntax (with-cwd dir . body)
|
||||
|
|
@ -891,7 +897,10 @@
|
|||
|
||||
|
||||
(define (really-fork clear-interactive? maybe-thunk)
|
||||
(((structure-ref interrupts with-interrupts-inhibited) (lambda ()
|
||||
(with-env-aligned* ; not neccessary here but doing it on exec
|
||||
; genereates no cache in the parent
|
||||
(lambda ()
|
||||
(((structure-ref interrupts with-interrupts-inhibited) (lambda ()
|
||||
(let ((pid (%%fork)))
|
||||
(if (zero? pid)
|
||||
|
||||
|
|
@ -907,7 +916,7 @@
|
|||
|
||||
;; Parent
|
||||
(let ((proc (new-child-proc pid)))
|
||||
(lambda () proc))))))))
|
||||
(lambda () proc))))))))))
|
||||
|
||||
|
||||
(define (exit . maybe-status)
|
||||
|
|
|
|||
138
scsh/syscalls.c
138
scsh/syscalls.c
|
|
@ -651,132 +651,6 @@ s48_value df_scm_sort_filevec(s48_value g1, s48_value g2)
|
|||
return S48_FALSE;
|
||||
}
|
||||
|
||||
s48_value df_scm_envvec(void)
|
||||
{
|
||||
extern s48_value scm_envvec(void);
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
s48_value r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = scm_envvec();
|
||||
ret1 = r1;
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_install_env(s48_value g1)
|
||||
{
|
||||
extern int install_env(s48_value );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
int r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = install_env(g1);
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_create_env(s48_value g1, s48_value mv_vec)
|
||||
{
|
||||
extern int create_env(s48_value , s48_value *);
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
int r1;
|
||||
s48_value r2 = 0;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = create_env(g1, &r2);
|
||||
ret1 = errno_or_false(r1);
|
||||
S48_VECTOR_SET(mv_vec,0,r2);
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_align_env(s48_value g1)
|
||||
{
|
||||
extern void align_env(s48_value );
|
||||
|
||||
|
||||
align_env(g1);
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
s48_value df_free_envvec(s48_value g1)
|
||||
{
|
||||
extern s48_value free_envvec(s48_value );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
s48_value r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = free_envvec(g1);
|
||||
ret1 = r1;
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_envvec_setenv(s48_value g1, s48_value g2)
|
||||
{
|
||||
extern s48_value envvec_setenv(s48_value , s48_value );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
s48_value r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = envvec_setenv(g1, g2);
|
||||
ret1 = r1;
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_getenv(s48_value g1, s48_value mv_vec)
|
||||
{
|
||||
extern char *getenv(const char *);
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
char *r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
||||
r1 = getenv(s48_extract_string(g1));
|
||||
ret1 = S48_VECTOR_REF(mv_vec,0);
|
||||
SetAlienVal(S48_CAR(ret1),(long) r1); S48_SET_CDR(ret1,strlen_or_false(r1));//str-and-len
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)
|
||||
|
||||
s48_value df_delete_env(s48_value g1)
|
||||
{
|
||||
extern s48_value delete_env(s48_value );
|
||||
s48_value ret1 = S48_FALSE;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
s48_value r1;
|
||||
|
||||
|
||||
|
||||
S48_GC_PROTECT_1(ret1);
|
||||
r1 = delete_env(g1);
|
||||
ret1 = r1;
|
||||
S48_GC_UNPROTECT();
|
||||
return ret1;
|
||||
}
|
||||
|
||||
s48_value df_sleep_until(s48_value g1)
|
||||
{
|
||||
extern s48_value sleep_until(time_t );
|
||||
|
|
@ -872,14 +746,10 @@ void s48_init_syscalls(void)
|
|||
S48_EXPORT_FUNCTION(df_pause);
|
||||
S48_EXPORT_FUNCTION(df_open_dir);
|
||||
S48_EXPORT_FUNCTION(df_scm_sort_filevec);
|
||||
S48_EXPORT_FUNCTION(df_scm_envvec);
|
||||
S48_EXPORT_FUNCTION(df_install_env);
|
||||
S48_EXPORT_FUNCTION(df_create_env);
|
||||
S48_EXPORT_FUNCTION(df_align_env);
|
||||
S48_EXPORT_FUNCTION(df_free_envvec);
|
||||
S48_EXPORT_FUNCTION(df_envvec_setenv);
|
||||
S48_EXPORT_FUNCTION(df_getenv);
|
||||
S48_EXPORT_FUNCTION(df_delete_env);
|
||||
S48_EXPORT_FUNCTION(scm_envvec);
|
||||
S48_EXPORT_FUNCTION(create_env);
|
||||
S48_EXPORT_FUNCTION(align_env);
|
||||
S48_EXPORT_FUNCTION(free_envvec);
|
||||
S48_EXPORT_FUNCTION(set_cloexec);
|
||||
S48_EXPORT_FUNCTION(fcntl_read);
|
||||
S48_EXPORT_FUNCTION(fcntl_write);
|
||||
|
|
|
|||
|
|
@ -808,68 +808,26 @@
|
|||
|
||||
;;; ENV->ALIST
|
||||
|
||||
(define-foreign %load-env (scm_envvec)
|
||||
desc)
|
||||
|
||||
(define (env->list)
|
||||
(%load-env))
|
||||
(define-stubless-foreign %load-env () "scm_envvec")
|
||||
|
||||
(define (environ-env->alist)
|
||||
(env-list->alist (env->list)))
|
||||
|
||||
(let ((env-list.envvec (%load-env)))
|
||||
(cons (env-list->alist (car env-list.envvec))
|
||||
(cdr env-list.envvec))))
|
||||
|
||||
|
||||
;;; ALIST->ENV
|
||||
|
||||
(define-foreign %install-env/errno
|
||||
(install_env (vector-desc env-vec))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-errno-syscall (%install-env env-vec) %install-env/errno)
|
||||
;;; (%create-env ((vector 'X) -> address))
|
||||
(define-stubless-foreign %create-env (envvec) "create_env")
|
||||
|
||||
;;; assumes aligned env
|
||||
(define (envvec-alist->env alist)
|
||||
(%install-env (alist->env-vec alist)))
|
||||
|
||||
;;; create new env for thread
|
||||
(define-foreign %create-env/errno
|
||||
(create_env (vector-desc env-vec))
|
||||
(to-scheme integer errno_or_false)
|
||||
desc)
|
||||
|
||||
(define-errno-syscall (%create-env env-vec)
|
||||
%create-env/errno
|
||||
bvec)
|
||||
|
||||
(define (alist->envvec alist)
|
||||
(%create-env (alist->env-vec alist)))
|
||||
|
||||
(define-foreign %align-env
|
||||
(align_env (desc))
|
||||
ignore)
|
||||
(define-stubless-foreign %align-env (envvec) "align_env")
|
||||
|
||||
(define-foreign %free-env
|
||||
(free_envvec (desc))
|
||||
desc)
|
||||
;;; GETENV, SETENV
|
||||
;;; they all assume an aligned env
|
||||
|
||||
|
||||
(define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry))
|
||||
desc)
|
||||
|
||||
(define (envvec-setenv name value)
|
||||
(%envvec-setenv name (string-append name "=" value)))
|
||||
|
||||
(define-foreign envvec-getenv (getenv (string var))
|
||||
static-string)
|
||||
|
||||
(foreign-source
|
||||
"#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
||||
"" "")
|
||||
|
||||
(define-foreign envvec-delete-env (delete_env (desc var))
|
||||
desc)
|
||||
(define-stubless-foreign %free-env (envvec) "free_envvec")
|
||||
|
||||
|
||||
;;; Fd-ports
|
||||
|
|
|
|||
219
scsh/syscalls1.c
219
scsh/syscalls1.c
|
|
@ -491,24 +491,11 @@ s48_value scsh_seteuid(s48_value uid)
|
|||
/* Environment hackery
|
||||
*******************************************************************************
|
||||
*/
|
||||
struct envvec {
|
||||
char **env; /* Null-terminated vector of strings. Malloc'd. */
|
||||
int size; /* Length of env. */
|
||||
int revealed; /* True => exported to C code */
|
||||
int gcable; /* True => no pointers to us from Scheme heap. */
|
||||
};
|
||||
/* Note that the SIZE field tells you how many words of memory are allocated
|
||||
** for the block of memory to which the ENV field points. This includes the
|
||||
** terminating null pointer, and may include more words beyond that. It is
|
||||
** *not* the number of strings stored in ENV; it is always greater than this
|
||||
** value.
|
||||
**
|
||||
** The REVEALED field is incremented if either the ENV block or the entire
|
||||
** struct is handed out to C code.
|
||||
**
|
||||
** If the structure becomes gc'able, but is REVEALED (hence cannot be freed),
|
||||
** the GC simply sets GCABLE and forgets about it.
|
||||
*/
|
||||
static s48_value envvec_record_type_binding = S48_FALSE;
|
||||
static s48_value add_envvec_finalizerB_binding = S48_FALSE;
|
||||
|
||||
#define ENVVEC_ENVIRON(envvec) \
|
||||
((char**) s48_extract_integer(S48_RECORD_REF((envvec),0)))
|
||||
|
||||
/* The envvec corresponding to the current environment.
|
||||
** Null if the current environment has no corresponding envvec struct
|
||||
|
|
@ -516,186 +503,101 @@ struct envvec {
|
|||
** startup time.) That is,
|
||||
** !current_env || current_env->env == environ
|
||||
*/
|
||||
struct envvec *current_env = 0;
|
||||
s48_value current_env = S48_FALSE;
|
||||
|
||||
void align_env(s48_value pointer_to_struct)
|
||||
s48_value align_env(s48_value envvec)
|
||||
{
|
||||
struct envvec* thread_env;
|
||||
thread_env = (struct envvec*) s48_extract_integer(pointer_to_struct);
|
||||
environ = thread_env->env;
|
||||
current_env = thread_env;
|
||||
environ = ENVVEC_ENVIRON(envvec);
|
||||
current_env = envvec;
|
||||
return S48_TRUE;
|
||||
}
|
||||
|
||||
s48_value free_envvec (s48_value pointer_to_struct)
|
||||
char** original_environ = 0;
|
||||
|
||||
s48_value free_envvec (s48_value envvec)
|
||||
{
|
||||
struct envvec* envv = (struct envvec*) s48_extract_integer(pointer_to_struct);
|
||||
int i;
|
||||
if (envv->revealed)
|
||||
char** env = ENVVEC_ENVIRON(envvec);
|
||||
int i=0;
|
||||
if (env == original_environ)
|
||||
{
|
||||
envv->gcable = 1;
|
||||
return S48_FALSE;
|
||||
}
|
||||
for (i=0; i<envv->size; i++)
|
||||
Free(envv->env[i]);
|
||||
Free(envv->env);
|
||||
Free(envv);
|
||||
while (env[i] != 0){
|
||||
Free(env[i]);
|
||||
i++;
|
||||
}
|
||||
Free(env);
|
||||
return S48_TRUE;
|
||||
}
|
||||
|
||||
s48_value envvec_setenv(s48_value scheme_name, s48_value entry){
|
||||
char * name = s48_extract_string(scheme_name);
|
||||
int namelen = strlen(name);
|
||||
char **ptr = environ;
|
||||
char ** newenv;
|
||||
int size;
|
||||
int number_of_entries = 0;
|
||||
char * newentry = Malloc(char, S48_STRING_LENGTH(entry) + 1);
|
||||
if ( !newentry) return s48_enter_fixnum(errno);
|
||||
s48_value make_envvec(char** newenv){
|
||||
s48_value thread_env;
|
||||
|
||||
if (!current_env) {
|
||||
fprintf(stderr, "no current_env, giving up" );
|
||||
exit (1);
|
||||
}
|
||||
size = current_env->size;
|
||||
while (*ptr){
|
||||
if ( ( strncmp(*ptr, name, namelen) == 0) && (*ptr)[namelen] == '=')
|
||||
{
|
||||
*ptr = strcpy(newentry,s48_extract_string(entry));
|
||||
return S48_FALSE;
|
||||
}
|
||||
ptr++;
|
||||
number_of_entries++;
|
||||
}
|
||||
if (number_of_entries >= size) { // I never had this problem, but...
|
||||
fprintf(stderr, "currupt env, giving up %d %d", number_of_entries,size);
|
||||
exit (1);
|
||||
}
|
||||
else if (number_of_entries < (size - 1)) // is space left after the NULL ?
|
||||
{
|
||||
*ptr = strcpy(newentry,s48_extract_string(entry));
|
||||
*++ptr = NULL;
|
||||
return S48_FALSE;
|
||||
}
|
||||
else // number_of_entries == (size - 1)
|
||||
{
|
||||
int newsize = size + 1; // TODO: add more
|
||||
char ** newenv = Malloc (char *, newsize);
|
||||
if( !newenv) return s48_enter_fixnum(errno);
|
||||
current_env->env = newenv;
|
||||
current_env->size = newsize;
|
||||
memcpy(newenv, environ, number_of_entries * sizeof (char *));
|
||||
newenv[number_of_entries] = strcpy(newentry, s48_extract_string(entry));
|
||||
newenv[number_of_entries + 1] = NULL;
|
||||
environ = newenv;
|
||||
return S48_FALSE;
|
||||
}
|
||||
thread_env = s48_make_record(envvec_record_type_binding);
|
||||
|
||||
S48_RECORD_SET(thread_env, 0, s48_enter_integer((long)newenv));
|
||||
s48_call_scheme(S48_SHARED_BINDING_REF(add_envvec_finalizerB_binding),
|
||||
1,
|
||||
thread_env);
|
||||
return thread_env;
|
||||
}
|
||||
|
||||
s48_value scm_envvec(){
|
||||
return char_pp_2_string_list(environ);
|
||||
s48_value thread_env;
|
||||
if (current_env == 0){
|
||||
thread_env = make_envvec(environ);
|
||||
current_env = thread_env;
|
||||
}
|
||||
else thread_env = current_env;
|
||||
|
||||
if (original_environ == 0)
|
||||
original_environ = environ;
|
||||
|
||||
return s48_cons (char_pp_2_string_list(environ),
|
||||
thread_env);
|
||||
}
|
||||
|
||||
|
||||
/* Load the (Scheme) strings in the (Scheme) vector VEC into environ.
|
||||
** Somewhat wasteful of memory: we do not free any of the memory
|
||||
** in the old environ -- don't know if it is being shared elsewhere.
|
||||
*/
|
||||
|
||||
int install_env(s48_value vec)
|
||||
s48_value create_env(s48_value vec)
|
||||
{
|
||||
int i, envsize;
|
||||
char **newenv;
|
||||
|
||||
envsize = S48_VECTOR_LENGTH(vec);
|
||||
|
||||
if (envsize >= (current_env->size))
|
||||
{
|
||||
newenv = Malloc(char*, envsize+1);
|
||||
if( !newenv ) return errno;
|
||||
Free(current_env->env);
|
||||
current_env->env = newenv;
|
||||
}
|
||||
else newenv = current_env->env;
|
||||
|
||||
for( i=0; i<envsize; i++ ) {
|
||||
char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
|
||||
if (!s) {
|
||||
/* Return all the memory and bail out. */
|
||||
int e = errno;
|
||||
while(--i) Free(newenv[i]);
|
||||
Free(newenv);
|
||||
return e;
|
||||
}
|
||||
newenv[i] = s;
|
||||
}
|
||||
|
||||
newenv[i] = NULL;
|
||||
environ = newenv;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int create_env(s48_value vec, s48_value * envvec_addr)
|
||||
{
|
||||
int i, envsize;
|
||||
char **newenv;
|
||||
struct envvec* thread_env;
|
||||
s48_value thread_env;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
S48_GC_PROTECT_1(vec);
|
||||
|
||||
envsize = S48_VECTOR_LENGTH(vec);
|
||||
|
||||
newenv = Malloc(char*, envsize+1);
|
||||
if( !newenv ) return errno;
|
||||
thread_env = Malloc (struct envvec, 4); // TODO: why 4 ??
|
||||
if( !thread_env ) {
|
||||
Free (newenv);
|
||||
return errno;
|
||||
}
|
||||
|
||||
thread_env->env = newenv;
|
||||
thread_env->size = envsize + 1;
|
||||
thread_env->revealed = 0;
|
||||
thread_env->gcable = 0;
|
||||
if( !newenv ) s48_raise_out_of_memory_error();
|
||||
|
||||
|
||||
for( i=0; i<envsize; i++ ) {
|
||||
char *s = scheme2c_strcpy(S48_VECTOR_REF(vec,i));
|
||||
if (!s) {
|
||||
/* Return all the memory and bail out. */
|
||||
int e = errno;
|
||||
while(--i) Free(newenv[i]);
|
||||
Free(newenv);
|
||||
Free(thread_env);
|
||||
return e;
|
||||
s48_raise_out_of_memory_error();
|
||||
}
|
||||
newenv[i] = s;
|
||||
}
|
||||
|
||||
newenv[envsize] = NULL;
|
||||
|
||||
*envvec_addr = s48_enter_integer((long) thread_env);
|
||||
|
||||
thread_env = make_envvec(newenv);
|
||||
environ = newenv;
|
||||
current_env = thread_env;
|
||||
|
||||
S48_GC_UNPROTECT();
|
||||
return thread_env;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* Delete the env var. */
|
||||
s48_value delete_env(s48_value name)
|
||||
{
|
||||
int varlen = S48_STRING_LENGTH (name);
|
||||
char * var = s48_extract_string (name);
|
||||
char **ptr = environ;
|
||||
char **ptr2;
|
||||
if (!current_env) {
|
||||
fprintf(stderr, "no current_env, giving up" );
|
||||
exit (1);
|
||||
}
|
||||
do if( !*++ptr ) return S48_FALSE;
|
||||
while( strncmp(*ptr, var, varlen) || (*ptr)[varlen] != '=' );
|
||||
ptr2 = ptr;
|
||||
while (*++ptr2);
|
||||
*ptr = *ptr2;
|
||||
*ptr2 = NULL;
|
||||
return S48_TRUE;
|
||||
}
|
||||
|
||||
|
||||
/*****************************************************************************/
|
||||
|
||||
/* N.B.: May be unaligned. */
|
||||
|
|
@ -766,3 +668,12 @@ s48_value scm_crypt(s48_value key, s48_value salt)
|
|||
|
||||
return s48_enter_string (ret);
|
||||
}
|
||||
|
||||
void s48_init_syscalls2(){
|
||||
S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
|
||||
S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
|
||||
S48_GC_PROTECT_GLOBAL(current_env);
|
||||
envvec_record_type_binding = s48_get_imported_binding("envvec-record-type");
|
||||
add_envvec_finalizerB_binding =
|
||||
s48_get_imported_binding("add-envvec-finalizer!");
|
||||
}
|
||||
|
|
|
|||
|
|
@ -65,13 +65,13 @@ s48_value scsh_setuid(s48_value uid);
|
|||
|
||||
s48_value scsh_seteuid(s48_value uid);
|
||||
|
||||
int put_env(const char *s);
|
||||
s48_value align_env(s48_value pointer_to_struct);
|
||||
|
||||
s48_value free_envvec (s48_value pointer_to_struct);
|
||||
|
||||
s48_value scm_envvec(void);
|
||||
|
||||
int install_env(s48_value vec);
|
||||
|
||||
s48_value delete_env(s48_value var);
|
||||
s48_value create_env(s48_value vec);
|
||||
|
||||
s48_value scm_gethostname(void);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue