figl/runtime.scm

   1 ;;; figl
   2 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   3 ;;;
   4 ;;; Figl is free software: you can redistribute it and/or modify it
   5 ;;; under the terms of the GNU Lesser General Public License as
   6 ;;; published by the Free Software Foundation, either version 3 of the
   7 ;;; License, or (at your option) any later version.
   8 ;;;
   9 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  10 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  11 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  12 ;;; Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU Lesser General Public
  15 ;;; License along with this program.  If not, see
  16 ;;; <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19 ;;
  20 ;; figl is the Foreign Interface to GL.
  21 ;;
  22 ;;; Code:
  23
  24 (define-module (figl runtime)
  25   #:use-module (system foreign)
  26   #:export (current-resolver
  27             define-foreign-procedure
  28             define-foreign-procedures
  29             define-foreign-type
  30             define-simple-foreign-type))
  31
  32 ;;
  33 ;; OpenGL and loading.  What a mess.  So, in the beginning, when
  34 ;; Microsoft added support for OpenGL to Windows, they did so via a
  35 ;; trampoline DLL.  This DLL had a fixed number of entry points, and it
  36 ;; was independent of the driver that the graphics card provided.  It
  37 ;; also provided an extension interface, wglGetProcAddress, which could
  38 ;; return additional GL procedures by name.  Microsoft was unwilling to
  39 ;; extend their trampoline DLL for whatever reason, and so on Windows
  40 ;; you always needed to wglGetProcAddress for almost any OpenGL
  41 ;; function.
  42 ;;
  43 ;; Time passed and GLX and other GL implementations started to want
  44 ;; extensions too.  This let application vendors ship applications that
  45 ;; could take advantage of the capabilities of users's graphics cards
  46 ;; without requiring that they be present.
  47 ;;
  48 ;; There are a couple of differences between WGL and GLX, however.
  49 ;; Chiefly, wglGetProcAddress can only be called once you have a
  50 ;; context, and the resulting function can only be used in that context.
  51 ;; In practice it seems that it can be used also in other contexts that
  52 ;; end up referring to that same driver and GPU.  GLX on the other hand
  53 ;; is context-independent, but presence of a function does not mean that
  54 ;; the corresponding functionality is actually available.  In theory
  55 ;; users have to check for the presence of the GL extension or check the
  56 ;; core GL version, depending on whether the interface is an extension
  57 ;; or in GL core.
  58 ;;
  59 ;; Because of this difference between the GLX and WGL semantics, there
  60 ;; is no core "glGetProcAddress" function.  It's terrible: each
  61 ;; windowing system is responsible for providing their own
  62 ;; function-loader interface.
  63 ;;
  64 ;; Finally, Guile needs to load up at least some interfaces using
  65 ;; dynamic-link / dynamic-pointer in order to be able to talk to the
  66 ;; library at all (and to open a context in the case of Windows), and it
  67 ;; happens that these interfaces also work fine for getting some of the
  68 ;; GL functionality!
  69 ;;
  70 ;; All of this mess really has very little place in the world of free
  71 ;; software, where dynamic linking is entirely sufficient to deal with
  72 ;; this issue, but it is how things have evolved.
  73 ;;
  74 ;; In light of all of this, we need to make some simplifications.
  75 ;;
  76 ;; One is that each low-level function will have just one foreign
  77 ;; function wrapper.  This means that a minority of Windows
  78 ;; configurations won't work.  Oh well.
  79 ;;
  80 ;; Another is that if dynamic-link returns a result, that it is assumed
  81 ;; that glXGetProcAddress (or the equivalent) would return the same
  82 ;; value.  So we can try dynamic-link first, and only dispatch to e.g
  83 ;; glXGetProcAddress if that fails.
  84 ;;
  85 ;; Finally, we assume that all GL symbols may be resolved by
  86 ;; dynamic-pointer by looking in one library, regardless of whether they
  87 ;; come from the lower GL level or from the window-system-specific
  88 ;; level.
  89 ;;
  90
  91 ;; FIXME: adapt implementation to match!
  92 (define (default-resolver name)
  93   (dynamic-pointer name (dynamic-link)))
  94
  95 (define current-resolver
  96   (make-parameter default-resolver))
  97
  98 (define (resolve name)
  99   ((current-resolver) name))
 100
 101 (define-syntax foreign-trampoline
 102   (lambda (stx)
 103     (syntax-case stx (->)
 104       ((_ trampoline
 105           name (pname ptype) ... -> type)
 106        (with-syntax ((sname (symbol->string (syntax->datum #'name))))
 107          #'(lambda (pname ...)
 108              (let ((ptr (resolve sname)))
 109                (set! trampoline
 110                      (pointer->procedure (type)
 111                                          ptr
 112                                          (list (ptype) ...)))
 113                (trampoline pname ...))))))))
 114
 115 (define-syntax define-foreign-procedure
 116   (syntax-rules (->)
 117     ((define-foreign-procedure (name (pname ptype) ... -> type)
 118        docstring)
 119      (define name
 120        (letrec ((trampoline
 121                  (foreign-trampoline trampoline
 122                                      name (pname ptype) ... -> type))
 123                 (name (lambda (pname ...)
 124                         docstring
 125                         (let ((pname (ptype #:unwrap pname))
 126                               ...)
 127                           (type #:wrap (trampoline pname ...))))))
 128          name)))))
 129
 130 (define-syntax define-foreign-procedures
 131   (syntax-rules ()
 132     ((define-foreign-procedures ((name prototype ...) ...)
 133        docstring)
 134      (begin
 135        (define-foreign-procedure (name prototype ...)
 136          docstring)
 137        ...))))
 138
 139 (define-syntax define-foreign-type
 140   (syntax-rules ()
 141     ((_ name ffi-type unwrap wrap)
 142      (define-syntax name
 143        (syntax-rules ()
 144          ((_) ffi-type)
 145          ((_ #:wrap x) (wrap x))
 146          ((_ #:unwrap x) (unwrap x)))))))
 147
 148 (define-syntax define-simple-foreign-type
 149   (syntax-rules ()
 150     ((_ name ffi-type)
 151      ;; We could dispatch through to define-foreign-type via:
 152      ;;
 153      ;;   (define-foreign-type name
 154      ;;     ffi-type
 155      ;;     (lambda (x) x)
 156      ;;     (lambda (x) x))
 157      ;;
 158      ;; However the resulting wrap expression:
 159      ;;
 160      ;;   ((lambda (x) x) (trampoline arg ...))
 161      ;;
 162      ;; would not be in tail position, as the optimizer doesn't know
 163      ;; that the foreign function just returns one value.  This hack
 164      ;; just passes the wrapped expression through, allowing it to be in
 165      ;; tail position.
 166      (define-syntax name
 167        (syntax-rules ()
 168          ((_) ffi-type)
 169          ((_ #:wrap x) x)
 170          ((_ #:unwrap x) x))))))