src/rclg-init.lisp

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