1 ;;; RCLG: R-CommonLisp Gateway
3 ;;; Copyright (c) 2005--2009, <rif@mit.edu>
4 ;;; AJ Rossini <blindglobe@gmail.com>
5 ;;; All rights reserved.
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
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.
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.
33 ;;; Author: rif@mit.edu
34 ;;; Maintainers: rif@mit.edu,
35 ;;; AJ Rossini <blindglobe@gmail.com>
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
41 ;;; But first things first.
44 ;; (start-rclg) ;; initializes RCLG functions.
45 ;; (update-R) ;; sync all threads (SBCL only, need to include others).
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
))
54 (in-package :rclg-init
)
57 (defvar *r-default-argv
*
58 '("rclg" "-q" "--vanilla" "--max-ppsize=50000")) ; last term incr stack
59 (defvar *r-started
* nil
)
62 (setf *r-interactive
* 1) ; nil?
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
)
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
)
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
*)
86 "Update and sync all SBCL threads containing R processes."
89 (%r-run-handlers
*r-input-handlers
*
90 (%r-check-activity
10000 0)))))
92 (defun start-rclg-update-thread ()
94 FIXME:AJR add use case for when/if needed at by a user."
95 (setf *do-rclg-updates-p
* t
)
97 (sb-thread:make-thread
99 (loop while
*do-rclg-updates-p
*
103 (sleep *rclg-update-sleep-time
*)))))
104 #+clisp
(error "not implemented yet")
105 #+cmu
(error "not implemented yet"))
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
112 (setf *do-rclg-updates-p
* nil
))
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
)))
120 (setf (mem-aref foreign-array
:pointer i
)
121 (foreign-string-alloc (elt string-sequence i
))))
122 (values foreign-array n
))))
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:
128 (let ((ctr (gensym)))
129 `(multiple-value-bind (,name
,length
)
130 (string-sequence-to-foreign-string-array ,str-array
)
134 (dotimes (,ctr
,length
)
136 (mem-aref ,name
:pointer
,ctr
)))
137 (foreign-free ,name
))))))
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
)
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))
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)))
159 (defun check-stack ()
160 (format t
"STACK: LIMIT ~A, HANDLERS ~A~%"
161 *R-CSTACKLIMIT
* *R-SIGNALHANDLERS
*)
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)
171 #+sbcl
(sb-int:set-floating-point-modes
:traps
(list :overflow
))
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?
179 #+sbcl
(start-rclg-update-thread)))))))
181 ;;; Commented out, since we let the user do it when ready.
182 ;;(eval-when (:load-toplevel)