Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

• e5777ecb
  by Raymond Toy at 2016-11-28T20:29:33-08:00

  Fix #26: Use nanosleep to sleep
  
  lisp/os-common.c:
  o Implement os_sleep(double) to sleep for the given number of
    seconds.  Uses nanosleep on all platforms to sleep, taking care to
    sleep more if nanosleep was interrupted.
  
  code/lispinit.lisp:
  code/multi-proc.lisp:
  o Use the new os_sleep function to sleep for the requested amount of
    time.
  

• 05585b8d
  by Raymond Toy at 2016-11-28T21:05:02-08:00

  Minor cosmetic tweaks
  
  o Include math.h before netdb.h (from Carl)
  o Use ceil instead of trunc and add comment on why.
  o Conform to cmucl style.
  

• 9e99edb8
  by Raymond Toy at 2016-11-28T21:14:27-08:00

  Add test for issue 26
  
  Basically used the repro case from the issue.
  

• f09db6e5
  by Raymond Toy at 2016-11-28T22:14:26-08:00

  Solaris needs -lrt library to get nanosleep.
  

• 1aae3ef9
  by Raymond Toy at 2016-11-29T19:01:54-08:00

  Verify the process ran and exited successfully
  

• 260c0e45
  by Raymond Toy at 2016-11-29T19:03:17-08:00

  Adjust comment
  

• fb864a9b
  by Raymond Toy at 2016-11-30T19:53:44-08:00

  Fix merge conflicts with master
  

• 8743d581
  by Raymond Toy at 2016-11-30T19:53:57-08:00

  Fix merge conflicts
  

• 5f7c4fea
  by Raymond Toy at 2016-12-02T03:37:16+00:00

  Merge branch 'rtoy-issue-26' into 'master'
  
  Fix #26: Use nanosleep to sleep without being interrupted
  
  First, use nanosleep to sleep instead of using select.  Then handle the case of nanosleep being interrupted wherein we keep calling nanosleep with the remaining time until the desired time has elapsed.
  
  See merge request !17

5 changed files:

• src/code/lispinit.lisp
• src/code/multi-proc.lisp
• src/lisp/Config.sparc_common
• src/lisp/os-common.c
• tests/issues.lisp

Changes:

           :format-arguments (list n)

           :datum n

           :expected-type '(real 0)))

  (multiple-value-bind (sec usec)

    (if (integerp n)

	(values n 0)

	(multiple-value-bind (sec frac) (truncate n)

	  (values sec (truncate frac 1e-6))))

    (unix:unix-select 0 0 0 0 sec usec))

  (alien:alien-funcall

   (alien:extern-alien "os_sleep" (function c-call:void double-float))

   (float n 1d0))

  nil)

;;;; SCRUB-CONTROL-STACK

	     ;; Can't call process-wait if the scheduling is inhibited.

	     *inhibit-scheduling*)

	 ;; The initial-process may block.

	 (multiple-value-bind (sec usec)

	     (if (integerp n)

		 (values n 0)

		 (multiple-value-bind (sec frac)(truncate n)

		   (values sec (truncate frac 1e-6))))

	   (unix:unix-select 0 0 0 0 sec usec))

	 (alien:alien-funcall

	  (alien:extern-alien "os_sleep" (function c-call:void double-float))

	  (float n 1d0))

	 nil)

	(t

	 (process-wait-with-timeout "Sleep" n (constantly nil)))))

DEPEND=$(CC) 

OS_SRC = solaris-os.c os-common.c elf.c

OS_LIBS= -lsocket -lnsl -ldl

OS_LIBS= -lsocket -lnsl -ldl -lrt

EXEC_FINAL_OBJ = exec-final.o

*/

#include <errno.h>

#include <math.h>

#include <netdb.h>

#include <stdio.h>

#include <string.h>

#include <time.h>

#include "os.h"

#include "internals.h"

  return n;

}

/*

 * sleep for the given number of seconds, even if we're interrupted.

 */

void

os_sleep(double seconds)

{

    struct timespec requested;

    struct timespec remaining;

    double integral;

    double fractional;

    fractional = modf(seconds, &integral);

    requested.tv_sec = (time_t) integral;

    /*

     * Round up---better to sleep slightly too long than to sleep for

     * too short a time.

     */

    requested.tv_nsec = (long) ceil(fractional * 1e9);

    while (nanosleep(&requested, &remaining) == -1 && errno == EINTR) {

	requested = remaining;

    }

}

    (:tag :issues)

  (loop for k from 1 to 24 do

    (assert-equal 0 (encode-universal-time 0 0 (- 24 k) 31 12 1899 k))))

(define-test issue.26

    (:tag :issues)

  (let ((start-time (get-universal-time)))

    (let ((p (ext:run-program "/usr/bin/env" '("sleep" "1") :wait nil)))

      (sleep 5)

      ;; For this test to be valid, the process must have finished

      ;; with a successful exit.

      (assert-true (eq (ext:process-status p) :exited))

      (assert-true (zerop (ext:process-exit-code p)))

      ;; We expect to have slept for at least 5 sec, but since

      ;; get-universal-time only has an accuracy of 1 sec, just verify

      ;; more than 3 sec have elapsed.

      (assert-true (>= (- (get-universal-time) start-time) 3)))))