scheduling etc

1 files changed, 280 insertions, 1 deletions

diff --git a/modules/language/python/module/os.scm b/modules/language/python/module/os.scm
index f4e1caf..29f7a5b 100644
--- a/modules/language/python/module/os.scm
+++ b/modules/language/python/module/os.scm
@@ -13,6 +13,7 @@
   #:use-module (language python yield)
   #:use-module (language python string)
   #:use-module (language python bytes)
+  #:use-module (language python module errno)
   #:use-module (language python list)
   #:export (error name ctermid environ environb chdir fchdir getcwd
                   fsencode fdencode fspath PathLike getenv getenvb
@@ -59,6 +60,21 @@
 
                   P_WAIT P_NOWAIT P_NOWAIT0
 
+                  P_PID P_PGID P_ALL
+                  WEXITED WUNTRACED WSTOPPED WNOWAIT WCONTINUED WNOHANG
+                  CLD_EXITED CLD_KILLED CLD_DUMPED CLD_STOPED CLD_TRAPPED
+                  CLD_CONTINUED
+
+                  startfile system times wait waitid waitpid wait3 wait4
+
+                  WCOREDUMP WIFCONTINUED WIFSTOPPED WIFSIGNALED WIFEXITED
+                  WEXITSTATUS WSTOPSIG WTERMSIG
+
+                  sched_get_priority_min sched_get_priority_max
+                  sched_setscheduler sched_getscheduler sched_setparam
+                  sched_getparam sched_rr_get_intervall sched_yield
+                  sched_setaffinity sched_getaffinity
+                  
                   ))
 
 (define error OSError)
@@ -1559,7 +1575,24 @@
 
 (define (plock . l) (error "not implemented"))
 
-(define popen)
+(define DEFAULT_BUFFER_SIZE 4096)
+(define* (popen com #:optional (mode "r") (buffering -1))
+  (let ((port (ca (open-pipe com (case mode
+                                   (("r")       OPEN_READ)
+                                   (("w")       OPEN_WRITE)
+                                   (("rw" "wr") OPEN_BOTH))))))
+    (ca
+     (case buffering
+       ((-1)
+        (setvbuf port 'block DEFAULT_BUFFER_SIZE))
+       ((0)
+        (setvbuf port 'none))
+       ((1)
+        (setvbuf port 'line))
+       (else
+        (setvbuf port 'block buffering))))
+    
+    port))
 
 (define P_WAIT 0)
 (define P_NOWAIT  1)
@@ -1587,6 +1620,134 @@
 (mk-spawn spawnvp   execvp)
 (mk-spawn spawnvpe  execvpe)
 
+(define startfile
+  (lambda x (error "not implemented")))
+
+(define (system command) (ca ((@ (guile) system) command)))
+
+(define-python-class Times ()
+  (define __init__
+    (lambda (self v)
+      (set self 'user            (tms:utime v))
+      (set self 'system          (tms:stime v))
+      (set self 'children_user   (tms:cutime v))
+      (set self 'children_system (tms:cstime v))
+      (set self 'elapsed         (tms:clock  v))))
+  (define __repr__
+    (lambda (self)
+      (format #f "Time(user:~a system:~a ...)"
+              (ref self 'user)
+              (ref self 'system)))))
+
+(define (times)
+  (ca (Times ((@ (guile) times)))))
+
+(define (wait)
+  (let ((x (wait-pid -1)))
+    (list (car x) (cdr x))))
+
+(define-python-class SigInfo ()
+  (define __init__
+    (lambda (self a b c d e)
+      (set self 'si_signo  a)
+      (set self 'si_code   b)
+      (set self 'si_pid    c)
+      (set self 'si_uid    d)
+      (set self 'si_status e)))
+
+  (define __repr__
+    (lambda (self)
+      (format #f
+              "SigInfo(signo:~a code:~a pid:~a uid:~a status:~a"
+              (ref self 'si_signo)
+              (ref self 'si_code)
+              (ref self 'si_pid)
+              (ref self 'si_uid)
+              (ref self 'si_status)))))
+      
+
+(define waitid
+  (let ((f (pointer->procedure int
+                                (dynamic-func "waitid" (dynamic-link))
+                                (int int '* int))))
+    (lambda (idtype id options)
+      (let* ((b         (make-bytevector 228))
+             (vp        (bytevector->pointer b))
+             (ref       (lambda (i) (bytebector-s32-ref
+                                     b i (native-endianess))))
+             (si_status (lambda () (ref 6)))
+             (si_code   (lambda () (ref 2)))
+             (si_pid    (lambda () (ref 4)))
+             (si_uid    (lambda () (ref 5)))
+             (si_signo  (lambda () (ref 0))))
+        (rm (f idtype id vp options))
+        (SigInfo (si_signo) (si_code) (si_pid) (si_uid)
+                 (si_status))))))
+
+(define P_PID  1)
+(define P_PGID 2)
+(define P_ALL  0)
+
+(define WEXITED 4)
+(define WUNTRACED 2)
+(define WSTOPPED 2)
+(define WNOWAIT #x01000000)
+(define WCONTINUED 8)
+(define WNOHANG 1)
+
+(define CLD_EXITED    1)
+(define CLD_KILLED    2)
+(define CLD_DUMPED    3)
+(define CLD_STOPED    5)
+(define CLD_TRAPPED   4)
+(define CLD_CONTINUED 6)
+
+(define (waitpid pid options)
+  (ca ((@ (guile) waitpid) pid options)))
+
+(define wait3
+  (let ((f (pointer->procedure int
+                                (dynamic-func "wait3" (dynamic-link))
+                                ('* int '*))))
+    (lambda (option)
+      (let* ((v  (make-bytevector 250))
+             (vp (bytevector->pointer v))
+             (w  (mkae-bytevector 8))
+             (wp (bytevector->pointer w)))
+
+        (let ((pid (rm (f wp option vp))))
+          (list pid
+                (bytevector-s32-ref w 0 (native-endianess))
+                (ResUsage v)))))))
+
+(define wait4
+  (let ((f (pointer->procedure int
+                               (dynamic-func "wait4" (dynamic-link))
+                               (int '* int '*))))
+    (lambda (pid option)
+      (let* ((v  (make-bytevector 250))
+             (vp (bytevector->pointer v))
+             (w  (mkae-bytevector 8))
+             (wp (bytevector->pointer w)))
+
+        (let ((pid2 (rm (f pid wp option vp))))
+          (list pid
+                (bytevector-s32-ref w 0 (native-endianess))
+                (ResUsage v)))))))
+
+(define __WCOREFLAG   #x80)
+(define __W_CONTINUED #xffff)
+(define (__WTERMSIG s) 
+(define (WCOREDUMP    status) (> (logand status __WCOREFLAG) 0))
+(define (WIFCONTINUED status) (=      status __W_CONTINUED))
+(define (WIFSTOPPED   status) (= (logand status #xff) #x7f))
+(define (WIFSIGNALED  status) (> (ash (+ (logand status 0x7f) 1) -1) 0))
+                                
+(define (WIFEXITED    status) (= (WTERMSIG status) 0))
+(define (WEXITSTATUS  status) (ash (logand status #xff00) 8))
+(define (WSTOPSIG     status) (WEXITSTATUS status))
+(define (WTERMSIG     status) (logand status #x7f))
+
 (define supprts_dir_fs
   (set '()))
 
@@ -1598,3 +1759,121 @@
 
 
 
+;; Scheduling
+
+(define SCHED_OTHER 0)
+(define SCHED_BATCH 3)
+(define SCHED_IDLE  5)
+(define SCHED_FIFO  1)
+(define SCHED_RR    2)
+(define SCHED_RESET_ON_FORK #x40000000)
+
+(define-python-class sched_param ()
+  (define __init__
+    (lambda (self v)
+      (if (bytevector? v)
+          (set self 'sched_priority
+               (bytevector-s32-ref v 0 (native-endianess)))
+          (set self 'sched_priority v)))))
+
+(define sched_get_priority_min
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_get_priority_min"
+                                             (dynamic-link))
+                               (list int))))
+    (lambda (policy) (rm (f policy)))))
+
+(define sched_get_priority_max
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_get_priority_max"
+                                             (dynamic-link))
+                               (list int))))
+    (lambda (policy) (rm (f policy)))))
+
+(define sched_setscheduler
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_setscheduler"
+                                             (dynamic-link))
+                               (list int int '*))))
+    (lambda (pid policy param)
+      (let* ((v  (make-bytevector 32))
+             (vp (bytevector->pointer v)))
+        (bytevector-s32-set! v 0 (ref param 'sched_priority)
+                             (native-endianess))
+        (rm (f pid policy vp))))))
+
+(define sched_getscheduler
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_getscheduler"
+                                             (dynamic-link))
+                               (list int))))
+    (lambda (pid)
+      (ca (f pid)))))
+
+(define sched_setparam
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_setparam"
+                                             (dynamic-link))
+                               (list int '*))))
+    (lambda (pid param)
+      (let* ((v  (make-bytevector 32))
+             (vp (bytevector->pointer v)))
+        (bytevector-s32-set! v 0 (ref param 'sched_priority)
+                             (native-endianess))
+        (rm (f pid vp))))))
+
+(define sched_getparam
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_getparam"
+                                             (dynamic-link))
+                               (list int '*))))
+    (lambda (pid param)
+      (let* ((v  (make-bytevector 32))
+             (vp (bytevector->pointer v)))
+        (rm (f pid vp))
+        (sched_param v)))))
+
+(define sched_rr_get_intervall
+  (lambda x (error "not implemented")))
+
+(define sched_yield
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_yield"
+                                             (dynamic-link))
+                               (list))))
+    (lambda () (rm (f)))))
+
+(define sched_setaffinity
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_setaffinity"
+                                             (dynamic-link))
+                               (list int int '*)))
+        (n (/ 1024 64)))
+    (lambda (pid mask)
+      (let* ((v  (make-bytecvector (/ 1024 64)))
+             (vp (bytevector->pointer v)))
+        
+        (for ((m : mask)) ()
+             (bytevector-u64-set! v i m (native-endianess)))
+
+        (rm (f pid (/ n 8) vp))))))
+
+(define sched_getaffinity
+  (let ((f (pointer->procedure int
+                               (dynamic-func "sched_getaffinity"
+                                             (dynamic-link))
+                               (list int int '*)))
+        (n (/ 1024 64)))
+    (lambda (pid)
+      (let* ((v  (make-bytecvector (/ 1024 64)))
+             (vp (bytevector->pointer v)))
+        
+        (rm (f pid (/ n 8) vp))
+        (let lp ((i 0))
+          (if (< i n)              
+              (cons (bytevector-u64-ref v i (native-endianess))
+                    (lp (+ i 1)))
+              '()))))))
+              
+
+;; MISC SYSTEM INFORMATION