From 557b799939b9b22ea912c27a36ca89645aa4933c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 6 Nov 2010 07:36:25 -0600 Subject: [PATCH] abandon gl-info inference of GL types via C compilation because it depends on locating GL headers at configure time, and it creates platform-specific code in the collects tree; the platforms that we support all have the obvious mappings for the GL types --- collects/sgl/gl-types.rkt | 121 ++++++++++------------- collects/sgl/info.rkt | 4 - collects/sgl/make-gl-info.rkt | 178 ---------------------------------- collects/sgl/makefile.rkt | 17 ---- 4 files changed, 51 insertions(+), 269 deletions(-) delete mode 100644 collects/sgl/make-gl-info.rkt delete mode 100644 collects/sgl/makefile.rkt diff --git a/collects/sgl/gl-types.rkt b/collects/sgl/gl-types.rkt index 17b0e824ad..163159ce86 100644 --- a/collects/sgl/gl-types.rkt +++ b/collects/sgl/gl-types.rkt @@ -1,76 +1,57 @@ -(module gl-types mzscheme - (require mzlib/foreign - "gl-info.ss") - - (provide (all-defined-except get-unsigned-type get-signed-type make-gl-vector-type)) +#lang racket/base +(require ffi/unsafe + ffi/cvector) - (define _float* - (make-ctype _float - (lambda (n) - (if (exact? n) - (exact->inexact n) - n)) - #f)) - - (define (get-unsigned-type size) - (case size - ((1) _uint8) - ((2) _uint16) - ((4) _uint32) - ((8) _uint64) - (else (error 'get-unsigned-type (format "no ~a byte unsigned type" size))))) +(provide (all-defined-out)) - (define (get-signed-type size) - (case size - ((1) _sint8) - ((2) _sint16) - ((4) _sint32) - ((8) _sint64) - (else (error 'get-signed-type (format "no ~a byte signed type" size))))) +(define _float* + (make-ctype _float + (lambda (n) + (if (exact? n) + (exact->inexact n) + n)) + #f)) - (define (make-gl-vector-type t) - (make-ctype _cvector - (lambda (sval) - (unless (cvector? sval) - (raise-type-error 'Scheme->C "cvector" sval)) - (unless (eq? (cvector-type sval) t) - (error 'Scheme->C "wrong kind of cvector")) - sval) - #f)) +(define (make-gl-vector-type t) + (make-ctype _cvector + (lambda (sval) + (unless (cvector? sval) + (raise-type-error 'Scheme->C "cvector" sval)) + (unless (eq? (cvector-type sval) t) + (error 'Scheme->C "wrong kind of cvector")) + sval) + #f)) - (define _gl-byte (get-signed-type gl-byte-size)) - (define _gl-ubyte (get-unsigned-type gl-ubyte-size)) - (define _gl-short (get-signed-type gl-short-size)) - (define _gl-ushort (get-unsigned-type gl-ushort-size)) - (define _gl-int (get-signed-type gl-int-size)) - (define _gl-uint (get-unsigned-type gl-uint-size)) - (define _gl-boolean (make-ctype (get-unsigned-type gl-boolean-size) - (lambda (x) - (if x 1 0)) - (lambda (x) (not (= x 0))))) - (define _gl-sizei (get-unsigned-type gl-sizei-size)) - (define _gl-enum (get-unsigned-type gl-enum-size)) - (define _gl-bitfield (get-unsigned-type gl-bitfield-size)) - (define _gl-float _float*) - (define _gl-double _double*) - (define _gl-clampf _float*) - (define _gl-clampd _double*) +;; Beware of problems with these type definitions. +;; They seem to be right for all currently supported +;; platforms, but in principle they can differ. - (define _gl-bytev (make-gl-vector-type _gl-byte)) - (define _gl-ubytev (make-gl-vector-type _gl-ubyte)) - (define _gl-shortv (make-gl-vector-type _gl-short)) - (define _gl-ushortv (make-gl-vector-type _gl-ushort)) - (define _gl-intv (make-gl-vector-type _gl-int)) - (define _gl-uintv (make-gl-vector-type _gl-uint)) - (define _gl-booleanv (make-gl-vector-type _gl-boolean)) - (define _gl-floatv (make-gl-vector-type _gl-float)) - (define _gl-doublev (make-gl-vector-type _gl-double)) - (define _gl-voidv _cvector) +(define _gl-byte _int8) +(define _gl-ubyte _uint8) +(define _gl-short _int16) +(define _gl-ushort _uint16) +(define _gl-int _int) +(define _gl-uint _uint) +(define _gl-boolean (make-ctype _int8 + (lambda (x) + (if x 1 0)) + (lambda (x) (not (= x 0))))) +(define _gl-sizei _int) +(define _gl-enum _int) +(define _gl-bitfield _uint) +(define _gl-float _float*) +(define _gl-double _double*) +(define _gl-clampf _float*) +(define _gl-clampd _double*) + +(define _gl-bytev (make-gl-vector-type _gl-byte)) +(define _gl-ubytev (make-gl-vector-type _gl-ubyte)) +(define _gl-shortv (make-gl-vector-type _gl-short)) +(define _gl-ushortv (make-gl-vector-type _gl-ushort)) +(define _gl-intv (make-gl-vector-type _gl-int)) +(define _gl-uintv (make-gl-vector-type _gl-uint)) +(define _gl-booleanv (make-gl-vector-type _gl-boolean)) +(define _gl-floatv (make-gl-vector-type _gl-float)) +(define _gl-doublev (make-gl-vector-type _gl-double)) +(define _gl-voidv _cvector) - ;; If GLfloat and GLdouble don't correspond to C's float and double, things - ;; won't work. - (unless (= gl-float-size (compiler-sizeof '(float))) - (error 'gl-float "GLfloat does not correspond to C's float type")) - (unless (= gl-double-size (compiler-sizeof '(double))) - (error 'gl-double "GLdouble does not correspond to C's double type")) - ) diff --git a/collects/sgl/info.rkt b/collects/sgl/info.rkt index 8bff6c45b1..48895031c4 100644 --- a/collects/sgl/info.rkt +++ b/collects/sgl/info.rkt @@ -1,9 +1,5 @@ #lang setup/infotab -(define pre-install-collection "makefile.rkt") -(define virtual-sources '("gl-info.rkt")) -(define clean (list (build-path "compiled" "native" (system-library-subpath)) - "compiled")) (define compile-omit-paths '("examples")) (define scribblings '(("scribblings/sgl.scrbl" (multi-page) (gui-library 50)))) diff --git a/collects/sgl/make-gl-info.rkt b/collects/sgl/make-gl-info.rkt deleted file mode 100644 index d4ee690ca3..0000000000 --- a/collects/sgl/make-gl-info.rkt +++ /dev/null @@ -1,178 +0,0 @@ -#lang mzscheme - -(require (prefix dynext: dynext/compile) - dynext/file - (prefix dynext: dynext/link) - mzlib/file - setup/dirs - launcher - srfi/13/string) - -(provide make-gl-info) - -(define c-file #< -#include -#include - -Scheme_Object *scheme_reload(Scheme_Env *env) -{ - Scheme_Env *mod_env; - - mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env); - scheme_add_global("gl-byte-size", - scheme_make_integer_value(sizeof(GLbyte)), - mod_env); - scheme_add_global("gl-ubyte-size", - scheme_make_integer_value(sizeof(GLubyte)), - mod_env); - scheme_add_global("gl-short-size", - scheme_make_integer_value(sizeof(GLshort)), - mod_env); - scheme_add_global("gl-ushort-size", - scheme_make_integer_value(sizeof(GLushort)), - mod_env); - scheme_add_global("gl-int-size", - scheme_make_integer_value(sizeof(GLint)), - mod_env); - scheme_add_global("gl-uint-size", - scheme_make_integer_value(sizeof(GLuint)), - mod_env); - scheme_add_global("gl-float-size", - scheme_make_integer_value(sizeof(GLfloat)), - mod_env); - scheme_add_global("gl-double-size", - scheme_make_integer_value(sizeof(GLdouble)), - mod_env); - scheme_add_global("gl-boolean-size", - scheme_make_integer_value(sizeof(GLboolean)), - mod_env); - scheme_add_global("gl-sizei-size", - scheme_make_integer_value(sizeof(GLsizei)), - mod_env); - scheme_add_global("gl-clampf-size", - scheme_make_integer_value(sizeof(GLclampf)), - mod_env); - scheme_add_global("gl-clampd-size", - scheme_make_integer_value(sizeof(GLclampd)), - mod_env); - scheme_add_global("gl-enum-size", - scheme_make_integer_value(sizeof(GLenum)), - mod_env); - scheme_add_global("gl-bitfield-size", - scheme_make_integer_value(sizeof(GLbitfield)), - mod_env); - scheme_finish_primitive_module(mod_env); - - return scheme_void; -} - -Scheme_Object *scheme_initialize(Scheme_Env *env) -{ - return scheme_reload(env); -} - -Scheme_Object *scheme_module_name(void) -{ - return scheme_intern_symbol("make-gl-info-helper"); -} - -end-string -) - -(define (delete/continue x) - (with-handlers ([exn:fail:filesystem? void]) - (delete-file x))) - -(define (parse-includes s) - (map (lambda (s) (substring s 2 (string-length s))) - (string-tokenize s))) - -(define (get-args which-arg) - (let ([fp (build-path (find-lib-dir) "buildinfo")]) - (if (file-exists? fp) - (call-with-input-file fp - (lambda (i) - (let loop ([l (read-line i)]) - (if (eof-object? l) - "" - (let ([m (regexp-match (format "^~a=(.*)$" which-arg) l)]) - (if m - (cadr m) - (loop (read-line i)))))))) - ""))) - -(define (compile-c-to-so file file.c file.so) - (let ([file.o (append-object-suffix file)]) - (dynext:compile-extension #f file.c file.o - `(,@(parse-includes (get-args "X_CFLAGS")) - ,(collection-path "compiler"))) - (dynext:link-extension #f (list file.o) file.so) - (delete/continue file.o))) - -(define (build-helper compile-directory variant) - (let* ([file "make-gl-info-helper.rkt"] - [c (build-path compile-directory (append-c-suffix file))] - [so (build-path compile-directory "native" - (system-library-subpath variant) - (append-extension-suffix file))]) - (make-directory* (build-path compile-directory "native" - (system-library-subpath variant))) - (with-output-to-file c (lambda () (display c-file)) 'replace) - (compile-c-to-so file c so))) - -(define (effective-system-type) - (let ([t (system-type)]) - (if (not (eq? t 'unix)) - t - ;; Check "buildinfo" for USE_GL flag: - (let ([buildinfo (build-path (find-lib-dir) "buildinfo")]) - (if (not (file-exists? buildinfo)) - (begin (printf "WARNING: buildinfo file missing: ~a\n" buildinfo) - t) - (with-input-from-file buildinfo - (lambda () - (if (regexp-match? #rx"-DUSE_GL" (current-input-port)) - t - (begin (printf "WARNING: no GL support\n") - 'no-gl))))))))) - -(define (make-gl-info compile-directory) - (let ([zo (build-path compile-directory (append-zo-suffix "gl-info.rkt"))] - [mod - (compile - (case (effective-system-type) - [(macosx windows no-gl) - `(,#'module gl-info mzscheme - (provide (all-defined)) - (define gl-byte-size 1) - (define gl-ubyte-size 1) - (define gl-short-size 2) - (define gl-ushort-size 2) - (define gl-int-size 4) - (define gl-uint-size 4) - (define gl-boolean-size 1) - (define gl-sizei-size 4) - (define gl-bitfield-size 4) - (define gl-enum-size 4) - (define gl-float-size 4) - (define gl-double-size 8) - (define gl-clampf-size 4) - (define gl-clampd-size 8))] - [else - (for-each (lambda (variant) - (parameterize ([dynext:link-variant variant]) - (build-helper compile-directory variant))) - (available-mzscheme-variants)) - `(,#'module gl-info mzscheme - (provide (all-defined)) - ,@(map - (lambda (x) - `(define ,x ,(dynamic-require 'sgl/make-gl-info-helper x))) - '(gl-byte-size gl-ubyte-size gl-short-size gl-ushort-size - gl-int-size gl-uint-size gl-boolean-size gl-sizei-size - gl-bitfield-size gl-enum-size gl-float-size gl-double-size - gl-clampf-size gl-clampd-size)))]))]) - (with-output-to-file zo - (lambda () (write mod)) - 'replace))) diff --git a/collects/sgl/makefile.rkt b/collects/sgl/makefile.rkt deleted file mode 100644 index fa0963d1c1..0000000000 --- a/collects/sgl/makefile.rkt +++ /dev/null @@ -1,17 +0,0 @@ -#lang mzscheme -(require make - setup/dirs - "make-gl-info.rkt") - -(provide pre-installer) - -(define dir (build-path "compiled")) - -(define (pre-installer home) - (parameterize ([current-directory (collection-path "sgl")] - [make-print-reasons #f] - [make-print-checking #f]) - (make/proc - `((,(build-path dir "gl-info_rkt.zo") - ("make-gl-info.rkt" ,(build-path (find-include-dir) "schvers.h")) - ,(lambda () (make-gl-info dir)))))))