It Seemed Like A Good Idea, At The Time

A while back I wrote a foreign function server called SoLoad.  It is intended for situations where a regular FFI, for whatever reason, is not available to you, but the permissions necessary to run and communicate with programs are available.

Once this was in place, I proceeded to write some code to take advantage of my program, and provide rudimentary C function capabilities to the Ikarus scheme implementation.  I got most of the code done, implementing portable type conversion functions, an implementation-independent interface to encapsulate the initialization and communication code, and all the little macros necessary to make the FFI easy to use.  It had its bugs, but it worked pretty well.  Well enough, at least, to create a window using SDL, and then close it again.

And then I just sort of forgot.  Somehow, after getting it all to work and provide a basic level of C library integration to Ikarus, I just wandered off and allowed myself to get involved in other projects.

Today, I was looking through my projects folder, and happened to notice the code I had previously forgotten.  Working under the assumption that someone could probably find a use for it, I decided that I would clean it up and post it online.

It required considerably less cleaning that I had expected.

Basic Structure of the Scheme->SoLoad Link

A major design goal in this project was designing it in a way that would allow it to be easily ported to a variety of Scheme implementations and communication channels.  The design I ultimately settled on was as follows:

There is one function, SOLOAD-INIT, which handles essentially all of the necessary setup, communication, and teardown code associated with using SoLoad.  When called, it is passed the path to the SoLoad executable, and calls it.  It then returns a pair, whose CAR is a function to send data to SoLoad and return whatever data SoLoad sends back, and whose CDR is a function that will tell SoLoad to exit and perform any other teardown functions that may be necessary.

Its implementation for Ikarus looks like this:

(import (ikarus))
;;;
;;; soload-init
;;;   Starts an instance of SoLoad
;;;   Returns a cons cell containing two functions:
;;;     car: Send a command to SoLoad, return the output.
;;;     cdr: Kill SoLoad and close all sockets.
;;;
(define (soload-init soload-path)
  ;; Start SoLoad, and bind its input, output, and error ports.
  (let-values ([(pid ip op errp)
                (process soload-path "stdin")])
    ;; Transcode the ports we'll be using.
    (let ([soload-in  (transcoded-port op (native-transcoder))]
          [soload-out (transcoded-port ip (native-transcoder))])
      (cons
       ;; Send commands to SoLoad
       (lambda (command)
         (unless (port-closed? soload-out)       ; Make sure it's open
                 (put-string soload-out command) ; Send the command
                 (newline soload-out)            ; Newline
                 (flush-output-port soload-out)) ; Flush the port
         (unless (port-closed? soload-in)        ; Make sure it's open
                 (get-line soload-in)))          ; Get the output
       ;; Kill SoLoad and close the ports
       (lambda ()
         (unless (port-closed? soload-out)       ; Make sure it's open
                 (put-string soload-out "exit\n"); Tell it to close
                 (flush-output-port soload-out)  ; Flush output
                 (close-port soload-out))        ; Close the port
         (unless (port-closed? soload-in)        ; Make sure it's open
                 (close-port soload-in))         ; Close the port
         (unless (port-closed? errp)             ; Make sure it's open
                 (close-port errp)))))))         ; Close the port

And that concludes the implementation-dependent portion of the interface.  All of the code above this level is (hopefully) completely independent of whatever particular Scheme it is running on.

Type Conversion

The next important part of the Ikarus/SoLoad FFI is the conversion between Scheme native types, and their text-based representation.

This consists of a myriad of small little functions, to escape/unescape strings, convert numbers, and flatten lists into a single string.  They are each easy to implement, and should be entirely portable Scheme code.

All together, they run a little long, but I may as well post them here as well:

;;
;; soload-escape
;;   Escape text so SoLoad will read it properly.
;;
(define (soload-escape text)
  (string-append "\"" text "\""))

;;
;; soload-unescape
;;   Remove the escaping from text that SoLoad returns.
;;
(define (soload-unescape text)
  (list->string
   (reverse
    (cdr
     (reverse
      (cdr
       (string->list text))))))) ; Remove quotation marks

;;
;; native->soload
;;   Converts a native type to a
;;   string representation that can
;;   be passed to SoLoad.
;;
(define (native->soload type value)
  (case type
    [(int float double long short
          uint8 sint8 uint16 sint16
          uint32 sint32 uint64 sint64
          ushort sshort uint sint
          ulong slong char uchar
          schar) (number->string value)]
    [(string char*)  (soload-escape value)]
    [(pointer void*) value]
    [(void) ""]
    [else "0"]))

;;
;; soload->native
;;   Converts a SoLoad string
;;   into a native type.
;;
(define (soload->native type value)
  (case type
    [(int float double long short
          uint8 sint8 uint16 sint16
          uint32 sint32 uint64 sint64
          ushort sshort uint sint
          ulong slong char uchar
          schar) (string->number value)]
    [(string char*)  (soload-unescape value)]
    [(pointer void*) value]
    [(void) #t]
    [else #f]))

(define (list:native->soload types values)
  (if (> (length types) 0)
      (cons
       (native->soload (car types) (car values))
       (list:native->soload (cdr types) (cdr values)))
      '()))

(define (list:soload->native types values)
  (if (> (length types) 0)
      (cons
       (soload->native (car types) (car values))
       (list:soload->native (cdr types) (cdr values)))
      '()))

(define (soload-flatten strings)
  (apply string-append
         (map
          (lambda (element) (string-append " " element))
          strings)))

Wrapping It All Up

These functions technically provide all the functionality required to use SoLoad from within Ikarus, but they lack a little something.  What they need now is to be made easy.  It should be possible to declare a function such that it just works from anywhere in your program, with no need to know that it’s calling a helper behind the scenes.

This is possibly the most involved portion of the interface, because it requires individually wrapping every function of SoLoad, and then adding a few macros to neaten things up.  In the end, though, I think it works out well:

(define soload-process #f)
(define soload-path "soload")

(define (soload-set-path path)
  (set! soload-path path))

(define (soload-send command)
  (if (equal? soload-process #f)
      (set! soload-process (soload-init soload-path)))
  ((car soload-process) command))

(define (soload-kill)
  (if (not (equal? soload-process #f))
      (begin
        ((cdr soload-process))
        (set! soload-process #f))))

(define (soload-library path)
  (soload-send (string-append "open " path)))

(define (soload-fn-load library name rtype atypes)
  (soload-send
   (string-append
    "load " library " " name " "
    (symbol->string rtype) " "
    (number->string (length atypes))
    (soload-flatten (map symbol->string atypes)))))

(define (soload-fn-call function rtype atypes args)
  (soload->native rtype
   (soload-send
    (string-append
     "call " function
     (soload-flatten
      (list:native->soload atypes args))))))

(define (soload-import definitions)
  (soload-send (string-append "def " definitions)))

(define (soload-type-define name . types)
  (soload-send
   (string-append "type " name " "
                  (number->string (length types))
                  (soload-flatten (map symbol->string types)))))

(define (soload-type-create name . args)
  (soload-send
   (string-append "new " name " "
                  (soload-flatten (list:native->soload types args)))))

(define (soload-delete name pointer)
  (soload-send (string-append "delete " name " " pointer)))

(define-syntax soload-function
  (syntax-rules ()
    ((_ library name (atypes ...) rtype)
     (let ([function (soload-fn-load library name
                                     'rtype '(atypes ...))])
       (lambda arguments
         (soload-fn-call function 'rtype
                         '(atypes ...) arguments))))
    ((_ library name (atypes ...))
     (soload-function library name (atypes ...) void))
    ((_ library name rtype)
     (soload-function library name () rtype))
    ((_ library name)
     (soload-function library name () void))))

;; Warning! SOLOAD-TYPE does not delete the stuff
;;   that it creates.  It will stick around till
;;   SoLoad is closed.
(define-syntax soload-type
  (syntax-rules ()
    ((_ name types ...)
     (let ([type (soload-type-define name types ...)])
       (lambda arguments
         (soload-send
          (string-append
           "new " name " "
           (soload-flatten
            (list:native->soload '(types ...) arguments)))))))))

Using It

Along with a working executable of SoLoad, this code should be all that is needed to use C libraries from within Ikarus.  I tested it roughly 5 minutes ago, so I’m fairly certain it works.  A working example, assuming all the previous code is in a file called “ikarus-soload.ss”, with the soload executable (or a symlink) in the same directory, is as follows:

(load "ikarus-soload.ss")

(soload-set-path "./soload")

;;;
;;; Math Check
;;;   Test the value of sin for progressively closer values of pi.
;;;   Should return numbers moving closer to 0
;;;

;; Import the library
(define libm (soload-library "/lib/libm.so.6"))
;; Import the function
(define s-sin (soload-function libm "sin" (double) double))
;; Do some tests
(newline)
(pretty-print (s-sin 3))
(pretty-print (s-sin 3.1))
(pretty-print (s-sin 3.14))
(pretty-print (s-sin 3.141))

;;;
;;; SDL Test
;;;   Load SDL, create a window, then quit
;;;

;; Load the library
(define lib-sdl
  (soload-library "/usr/lib/libSDL.so"))
;; Load a bunch of functions
(define sdl-init
  (soload-function lib-sdl "SDL_Init" (uint32) int))
(define sdl-quit
  (soload-function lib-sdl "SDL_Quit"))
(define sdl-set-video-mode
  (soload-function lib-sdl "SDL_SetVideoMode" (int int int uint32) pointer))
(define sdl-fill-rect
  (soload-function lib-sdl "SDL_FillRect" (pointer pointer uint32) int))
(define sdl-flip
  (soload-function lib-sdl "SDL_Flip" (pointer) int))
(define sdl-map-rgb
  (soload-function lib-sdl "SDL_MapRGB" (pointer uint8 uint8 uint8) uint32))
;; Declare a type
(define SDL_Rect*
  (soload-type "SDL_Rect" 'sint16 'sint16 'uint16 'uint16))

(sdl-init 0)
(define sdl-surface (sdl-set-video-mode 640 480 16 0))
(sdl-fill-rect sdl-surface (SDL_Rect* 0 0 640 480) 32535)
(sdl-flip sdl-surface)

(sdl-quit)
(soload-kill)

Now that I’ve taken a break from this for a while, I can see a few areas it could be made more robust.  Next feature: an optional timeout period for SoLoad, so it can close gracefully even if the caller has crashed.