scheduling etc

3 files changed, 458 insertions, 14 deletions

diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm
index 2922f3f..9c75658 100644
--- a/modules/language/python/exceptions.scm
+++ b/modules/language/python/exceptions.scm
@@ -5,23 +5,25 @@
                           Exception ValueError TypeError
                           IndexError KeyError AttributeError
                           SyntaxError SystemException
-                          OSError
+                          OSError ProcessLookupError PermissionError
                           None))
 
 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
 
-(define StopIteration    'StopIteration)
-(define GeneratorExit    'GeneratorExit)
-(define SystemException  'SystemException)
-(define RuntimeError     'RuntimeError)
-(define IndexError       'IndexError)
-(define ValueError       'ValueError)
-(define None             'None)
-(define KeyError         'KeyError)
-(define TypeError        'TypeError)
-(define AttributeError   'AttributeError)
-(define SyntaxError      'SyntaxError)
-(define OSError          'OSError)
+(define StopIteration      'StopIteration)
+(define GeneratorExit      'GeneratorExit)
+(define SystemException    'SystemException)
+(define RuntimeError       'RuntimeError)
+(define IndexError         'IndexError)
+(define ValueError         'ValueError)
+(define None               'None)
+(define KeyError           'KeyError)
+(define TypeError          'TypeError)
+(define AttributeError     'AttributeError)
+(define SyntaxError        'SyntaxError)
+(define OSError            'OSError)
+(define ProcessLookupError 'ProcessLookupError)
+(define PermissionError    'PermissionError)
 
 (define-python-class Exception ()
   (define __init__
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
diff --git a/modules/language/python/module/resource.scm b/modules/language/python/module/resource.scm
new file mode 100644
index 0000000..200127e
--- /dev/null
+++ b/modules/language/python/module/resource.scm
@@ -0,0 +1,163 @@
+(define-module (language python module resource)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (language python exceptions)
+  #:use-module (language python module errno)
+  #:use-module (language python try)
+  #:use-module (language python list)
+  #:export (RLIM_INFINITY RLIMIT_CORE RLIMIT_CPU RLIMIT_FSIZE RLIMIT_DATA
+                          RLIMIT_STACK RLIMIT_RSS RLIMIT_NPROC RLIMIT_NOFILE
+                          RLIMIT_MEMLOCK RLIMIT_AS RLIMIT_LOCKS
+                          RLIMIT_MSGQUEUE RLIMIT_NICE RLIMIT_RTPRIO
+                          RLIMIT_RTTIME RLIMIT_SIGPENDING
+
+                          getrlimit setrlimit prlimit
+
+                          RUSAGE_SELF RUSAGE_CHILDREN RUSAGE_BOTH RUSAGE_THREAD
+                          getrusage getpagesize
+
+                          ResUsage
+                          ))
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+(define-syntax-rule (ca code)
+  (catch #t
+    (lambda () code)
+    (lambda x (raise error x))))
+(define-syntax-rule (rm code (m . mm) ...)
+  (let ((r (ca code)))
+    (if (< r 0)
+        (let ((e (errno)))
+          (cond
+           ((= e m) mm) ...
+           (else
+            (raise OSError (pylist-ref errorcode e) ((@ (guile) strerror) e)))))
+        (values))))
+
+(define RLIM_INFINITY #xffffffffffffffff)
+
+(define RLIMIT_CORE        4)
+(define RLIMIT_CPU         0)
+(define RLIMIT_FSIZE       1)
+(define RLIMIT_DATA        2)
+(define RLIMIT_STACK       3)
+(define RLIMIT_RSS         5)
+(define RLIMIT_NPROC       6)
+(define RLIMIT_NOFILE      7)
+(define RLIMIT_MEMLOCK     8)
+(define RLIMIT_AS          9)
+(define RLIMIT_LOCKS      10)
+(define RLIMIT_MSGQUEUE   12)
+(define RLIMIT_NICE       13)
+(define RLIMIT_RTPRIO     14)
+(define RLIMIT_RTTIME     15)
+(define RLIMIT_SIGPENDING 11)
+
+(define getrlimit
+  (let ((f (pointer->procedure int
+                               (dynamic-func "getrlimit" (dynamic-link))
+                               (int '*))))
+    (lambda (resource)
+      (let* ((v  (make-bytevector 16))
+             (vp (bytevector->pointer v)))
+        (rm (f res vp) (EINVAL (raise ValueError "wrong resource")))
+        (list (bytevector-u64-ref v 0 (native-endianess))
+              (bytevector-u64-ref v 1 (native-endianess)))))))
+
+(define setrlimit
+  (let ((f (pointer->procedure int
+                               (dynamic-func "setrlimit" (dynamic-link))
+                               (int '*))))
+    (lambda (resource limits)
+      (let* ((v  (make-bytevector 16))
+             (vp (bytevector->pointer v)))
+        (bytevector-u64-set! v 0 (pylist-ref limits 0) (native-endianess))
+        (bytevector-u64-set! v 1 (pylist-ref limits 1) (native-endianess))
+        (rm (f resource vp)
+            (EINVAL (raise ValueError "wrong resource"))
+            (EPERM  (raise ValueError "wrong permission")))
+        (values)))))
+
+(define prlimit
+  (let ((f (pointer->procedure int
+                               (dynamic-func "prlimit" (dynamic-link))
+                               (int int '* '*))))
+    (lambda* (pid resource #:optional (limits None))
+      (let ((vnew  (make-bytevector 16))
+            (vold  (make-bytevector 16))
+            (vpnew (bytevector->pointer vnew))
+            (vpold (bytevector->pointer vold)))
+        (if (not (equal? limits None))
+            (begin
+              (bytevector-u64-set! vnew 0 (pylist-ref limits 0)
+                                   (native-endianess))
+              (bytevector-u64-set! vnew 1 (pylist-ref limits 1)
+                                   (native-endianess))))
+        (rm (f pid resource
+               (if (eq? limits None)
+                   (adress-pointer 0)
+                   vpnew)
+               vpold)
+            (EINVAL (raise ValueError "wrong resource"))
+            (ESRCH  (raise ProcessLookupError "prlimit"))
+            (EPERM  (raise PermissionError "prlimit")))
+        
+        (list (bytevector-u64-ref vold 0 (native-endianess))
+              (bytevector-u64-ref vold 1 (native-endianess)))))))
+
+        
+(define RUSAGE_SELF       0)
+(define RUSAGE_CHILDREN  -1)
+(define RUSAGE_BOTH      -2)
+(define RUSAGE_THREAD     1)
+
+(define-python-class ResUsage ()
+  (define __init__
+    (lambda (self v)
+      (define i 0)
+      (define-syntax-rule (gettime k)
+        (let ((x1 (bytevector-u64-ref v i (native-endianess)))
+              (x2 (bytevector-u64-ref v (+ i 1) (native-endianess))))
+          (set! i (+ i 2))
+          (set self k (+ (* x1 1.0) (/ (* x2 1.0) 1000000)))))
+      (define-syntax-rule (s k)
+        (begin
+          (set self k (bytevector-u64-ref v i (native-endianess)))
+          (set! i (+ i 1))))
+      (gettime 'ru_utime)
+      (gettime 'ru_stime)
+      (s 'ru_maxrss)
+      (s 'ru_ixrss )
+      (s 'ru_idrss )
+      (s 'ru_isrss )
+      (s 'ru_minflt)
+      (s 'ru_majflt)
+      (s 'ru_nswap)
+      (s 'ru_inblock)
+      (s 'ru_outblock)
+      (s 'ru_msgsnd)
+      (s 'ru_msgrcv)
+      (s 'ru_nsignals)
+      (s 'ru_nvcsw)
+      (s 'ru_nivcsw))))
+
+(define getrusage
+  (let ((f (pointer->procedure int
+                               (dynamic-func "getrusage" (dynamic-link))
+                               (int '*))))
+    (lambda (who)
+      (let* ((v  (make-bytevector 160))
+             (vp (bytevector->pointer)))
+        
+        (rm (f who vp)
+            (EINVAL (raise ValueError "wrong who in getrusage")))
+
+        (ResUsage v)))))
+
+(define getpagesize
+  (let ((f (pointer->procedure int
+                               (dynamic-func "getpagesize" (dynamic-link))
+                               ())))
+    (lambda ()
+      (rm (f)))))
+