src/rclg-init.lisp

   1 ;;; RCLG: R-CommonLisp Gateway
   2
   3
   4 ;;; Copyright (c) 2005--2007, <rif@mit.edu>
   5 ;;;                           AJ Rossini <blindglobe@gmail.com>
   6 ;;; All rights reserved.
   7 ;;;
   8 ;;; Redistribution and use in source and binary forms, with or without
   9 ;;; modification, are permitted provided that the following conditions are
  10 ;;; met:
  11 ;;;
  12 ;;;     * Redistributions of source code must retain the above copyright
  13 ;;;       notice, this list of conditions and the following disclaimer.
  14 ;;;     * Redistributions in binary form must reproduce the above
  15 ;;;       copyright notice, this list of conditions and the following disclaimer
  16 ;;;       in the documentation and/or other materials provided with the
  17 ;;;       distribution.
  18 ;;;     * The names of the contributors may not be used to endorse or
  19 ;;;       promote products derived from this software without specific
  20 ;;;       prior written permission.
  21 ;;;
  22 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23 ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24 ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  25 ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  26 ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  27 ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  28 ;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  29 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  30 ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  31 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  32 ;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  33
  34 ;;; Author:      rif@mit.edu
  35 ;;; Maintainers: rif@mit.edu,
  36 ;;;              AJ Rossini <blindglobe@gmail.com>
  37
  38 ;;; Intent: R evaluator process initialization and maintenance.  A
  39 ;;;         good deal of this is SBCL specific, and is flagged if so.
  40 ;;;         At some point, a means of handling non-SBCL variants will
  41 ;;;         be important.
  42 ;;;         But first things first.
  43
  44 ;;; Basic Usage:
  45 ;; (start-rclg) ;; initializes RCLG functions.
  46 ;; (update-R)   ;; sync all threads
  47 ;;
  48
  49 (defpackage :rclg-init
  50   (:use :common-lisp :rclg-foreigns :cffi)
  51   (:export :start-rclg :update-R :*r-started*
  52            :start-rclg-update-thread :stop-rclg-update-thread
  53            :with-R-traps :with-r-mutex))
  54
  55 (in-package :rclg-init)
  56
  57 ;; initialization
  58 (defvar *r-default-argv*
  59   '("rclg" "-q" "--vanilla" "--max-ppsize=50000")) ; last term to incr stack
  60 (defvar *r-started* nil)
  61
  62 ;; thread management
  63 (defvar *do-rclg-updates-p* nil)
  64 (defvar *rclg-update-sleep-time* .1)
  65 (defvar *rclg-update-mutex*
  66   #+sbcl(sb-thread:make-mutex)
  67   #-sbcl nil
  68   )
  69
  70 #+sbcl
  71 (defmacro with-r-traps (&body body)
  72   "Protect against R signaling wierdness to initialize the R REPL."
  73   `(sb-int:with-float-traps-masked  (:invalid :divide-by-zero)
  74     ,@body))
  75
  76 #+sbcl
  77 (defmacro with-r-mutex (&body body)
  78   "FIXME:AJR: eval body in an mutex thread, updating as necessary.  AJR is
  79 not clear about the use-case for this macro."
  80   `(sb-thread:with-mutex (*rclg-update-mutex*)
  81     ,@body))
  82
  83 (defun update-R ()
  84   "Update and sync all SBCL threads containing R processes."
  85   (with-r-traps
  86     (with-r-mutex
  87       (%r-run-handlers *r-input-handlers*
  88                        (%r-check-activity 10000 0)))))
  89
  90 (defun start-rclg-update-thread ()
  91   "Update R threads.
  92 FIXME:AJR add use case for when/if needed at by a user."
  93   (setf *do-rclg-updates-p* t)
  94   #+sbcl
  95   (sb-thread:make-thread
  96    #'(lambda ()
  97        (loop while *do-rclg-updates-p*
  98              do
  99              (progn
 100                (update-R)
 101                (sleep *rclg-update-sleep-time*)))))
 102   #+clisp(error "not implemented yet")
 103   #+cmu(error "not implemented yet"))
 104
 105
 106 (defun stop-rclg-update-thread ()
 107   "FIXME: this was initially flagged as SBCL only, but it is more
 108 generic.  However, it isn't useful until implemented on other CL
 109 systems."
 110   (setf *do-rclg-updates-p* nil))
 111
 112 (defun string-sequence-to-foreign-string-array (string-sequence)
 113   "CFFI-based conversion.  Isn't there a new CFFI function for this?
 114 FIXME:AJR: need to check."
 115   (let ((n (length string-sequence)))
 116     (let ((foreign-array (foreign-alloc :pointer :count n)))
 117       (dotimes (i n)
 118         (setf (mem-aref foreign-array :pointer i)
 119               (foreign-string-alloc (elt string-sequence i))))
 120       (values foreign-array n))))
 121
 122 (defmacro with-foreign-string-array
 123     ((name length str-array) &body body)
 124   "CFFI-based conversion.  Isn't this implemented in CFFI? FIXME:AJR:
 125 need to check."
 126   (let ((ctr (gensym)))
 127     `(multiple-value-bind (,name ,length)
 128       (string-sequence-to-foreign-string-array ,str-array)
 129       (unwind-protect
 130            ,@body
 131         (progn
 132           (dotimes (,ctr ,length)
 133             (foreign-string-free
 134              (mem-aref ,name :pointer ,ctr)))
 135           (foreign-free ,name))))))
 136
 137 ;; FIXME:AJR what is the point of the equiv comments?  i.e. signed-long?
 138 (defcvar ( "R_CStackLimit" *R-CSTACKLIMIT*)
 139     #-:x86-64 :unsigned-long
 140     #+:x86-64 :unsigned-long-long)
 141 (defcvar "R_SignalHandlers"
 142     #-:x86-64 :unsigned-long
 143     #+:x86-64 :unsigned-long-long)
 144
 145 (defun r-turn-off-signal-handling ()
 146   "Turn of stack checking, based on changes present in 2.3.1 release."
 147   (setf *R-SIGNALHANDLERS* 0))
 148
 149 (defun r-turn-off-stack-checking ()
 150   ;; (setf *R-CSTACKLIMIT* -1))
 151   ;; This following is a complete hack since CFFI currently doesn't
 152   ;; believe the above (it thinks that it's unsigned so upchucks)
 153   (setf *R-CSTACKLIMIT*
 154         #-:x86-64 #.(- (expt 2 32) 1)
 155         #+:x86-64 #.(- (expt 2 64) 1)))
 156
 157 (defun check-stack ()
 158   (format t "STACK: LIMIT ~A, HANDLERS ~A~%"
 159           *R-CSTACKLIMIT* *R-SIGNALHANDLERS*)
 160   (force-output t))
 161 ;;(check-stack)
 162
 163
 164 (defun start-rclg (&optional (argv *r-default-argv*))
 165   "Initial the first R thread, perhaps with different arguments."
 166   (r-turn-off-signal-handling)
 167   (unless *r-started*
 168     (progn
 169       #+sbcl(sb-int:set-floating-point-modes :traps (list :overflow))
 170       (setf *r-started*
 171             (progn
 172               (with-foreign-string-array (foreign-argv n argv)
 173                 (%rf-initialize-r n foreign-argv)
 174                 (r-turn-off-stack-checking)
 175                 (%setup-r-main-loop)
 176                 #+sbcl(start-rclg-update-thread)))))))
 177
 178 ;; FIXME:AJR: Do we really want to force this, or should we wait and
 179 ;; let the user do this when appropriate?
 180 ;; We let the user do it when ready.
 181
 182 ;;(eval-when (:load-toplevel)
 183 ;;  (start-rclg))