diff --git a/alloy/renderer.lisp b/alloy/renderer.lisp index 3db9dabd0..8116794e2 100644 --- a/alloy/renderer.lisp +++ b/alloy/renderer.lisp @@ -119,7 +119,7 @@ (%gl:uniform-1f loc value))))) (defmethod opengl:bind ((shader trial:shader-program)) - (gl:use-program (trial:gl-name shader))) + (trial:activate shader)) (defmethod alloy:allocate ((shader trial:shader)) (trial:allocate shader)) @@ -165,10 +165,8 @@ :vertex-form NIL)) (defmethod opengl:draw-vertex-array ((array trial:vertex-array) primitive-type offset count) - (gl:bind-vertex-array (trial:gl-name array)) - (if (trial:indexed-p array) - (%gl:draw-elements primitive-type count (trial:element-type (trial:indexed-p array)) offset) - (%gl:draw-arrays primitive-type offset count))) + (setf (trial:size array) count) + (trial:render array offset)) (defclass framebuffer (trial:framebuffer) ((target :initform NIL :accessor target))) @@ -196,15 +194,10 @@ (defmethod opengl:bind ((framebuffer trial:framebuffer)) (setf (target framebuffer) (gl:get-integer :draw-framebuffer-binding)) - (gl:bind-framebuffer :draw-framebuffer (gl-resource-name framebuffer)) - (gl:clear :color-buffer :depth-buffer :stencil-buffer)) + (trial:activate framebuffer)) (defmethod opengl:blit-framebuffer ((framebuffer trial:framebuffer)) - (gl:bind-framebuffer :read-framebuffer (trial:gl-name framebuffer)) - (gl:bind-framebuffer :draw-framebuffer (target framebuffer)) - (let ((w (trial:width framebuffer)) - (h (trial:height framebuffer))) - (%gl:blit-framebuffer 0 0 w h 0 0 w h '(:color-buffer :depth-buffer :stencil-buffer) :nearest))) + (trial:render framebuffer (target framebuffer))) (defclass image (trial:texture simple:image) ()) @@ -266,8 +259,7 @@ (trial:deallocate texture)) (defmethod opengl:bind ((texture trial:texture)) - (gl:active-texture :texture0) - (gl:bind-texture :texture-2D (trial:gl-name texture))) + (trial:bind texture NIL)) (defmethod simple:size ((image trial:image)) (alloy:size (trial:width image) (trial:height image))) diff --git a/alloy/ui.lisp b/alloy/ui.lisp index 572088dbe..5843ca0a1 100644 --- a/alloy/ui.lisp +++ b/alloy/ui.lisp @@ -131,10 +131,8 @@ (trial:stage (trial:framebuffer pass) area)) (defmethod trial:render :around ((pass ui-pass) target) - (trial:with-pushed-features - (trial:enable-feature :depth-test) - (gl:clear-color 0 0 0 0) - (call-next-method))) + (setf (clear-color *context*) 0) + (call-next-method)) ;; KLUDGE: No idea why this is necessary, fuck me. (defmethod simple:request-font :around ((pass ui-pass) font &key) diff --git a/assets/environment-map.lisp b/assets/environment-map.lisp index 3ec42e95f..efcff63b3 100644 --- a/assets/environment-map.lisp +++ b/assets/environment-map.lisp @@ -57,7 +57,7 @@ ;; then we let GL bake the mips for the envmap. (setf (min-filter envmap) :linear) (render envmap-renderer envmap) - (gl:bind-texture (target envmap) (gl-name envmap)) + (bind envmap NIL) (setf (min-filter envmap) :linear-mipmap-linear) ;; Now map the irradiance and prefiltered maps as usual. (render irrmap-renderer irrmap) diff --git a/assets/shader-image.lisp b/assets/shader-image.lisp index 0e2f30d2d..f68f3dd8f 100644 --- a/assets/shader-image.lisp +++ b/assets/shader-image.lisp @@ -18,15 +18,13 @@ (render (// 'trial 'fullscreen-square) program)) (defmethod render ((renderer image-renderer) (texture texture)) - (let ((fbo (gl:gen-framebuffer))) - (gl:bind-framebuffer :framebuffer fbo) + (let ((framebuffer (make-instance 'framebuffer :data-pointer (gl:gen-framebuffer)))) (unwind-protect (progn - (gl:viewport 0 0 (width texture) (height texture)) - (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name texture) 0) + (bind texture framebuffer) + (activate framebuffer) (render renderer NIL)) - (gl:bind-framebuffer :framebuffer 0) - (gl:delete-framebuffers (list fbo))))) + (deallocate framebuffer)))) (define-class-shader (image-renderer :vertex-shader) " diff --git a/context.lisp b/context.lisp index ef0ac0552..3e6a32bf0 100644 --- a/context.lisp +++ b/context.lisp @@ -46,15 +46,11 @@ (wait-lock :initform (bt:make-lock "Context wait lock") :reader context-wait-lock) (handler :initarg :handler :accessor handler) (shared-with :initarg :share-with :reader shared-with) - (glsl-target-version :initarg :glsl-version :initform NIL :accessor glsl-target-version) (binding-point-allocator :initform (make-array 256 :element-type 'bit) :accessor binding-point-allocator)) (:default-initargs :title "Trial" :width 1280 :height 720 - :glsl-version NIL - :version '(3 3) - :profile :core :double-buffering T :stereo-buffer NIL :vsync :off @@ -134,8 +130,7 @@ (call-next-method) (v:info :trial.context "Recreated context successfully.") (make-current context) - (context-note-debug-info context) - (cache-gl-extensions))) + (context-note-debug-info context))) (defmethod current-p ((context context) &optional (thread (bt:current-thread))) (eql thread (current-thread context))) @@ -208,64 +203,12 @@ (defmethod describe-object :after ((context context) stream) (context-info context stream)) -(defun context-info (context &key (stream *standard-output*) (show-extensions T)) - (format stream "~&~%Running GL~a.~a ~a~%~ - Sample buffers: ~a (~a sample~:p)~%~ - Max texture size: ~a~%~ - Max texture units: ~a ~a ~a ~a ~a ~a~%~ - ~@[~{Max compute groups: ~a ~a ~a~%~ - Max work groups: ~a ~a ~a (~a)~%~}~]~ - GL Vendor: ~a~%~ - GL Renderer: ~a~%~ - GL Version: ~a~%~ - GL Shader Language: ~a~%~ - ~@[GL Extensions: ~{~a~^ ~}~%~]" - (gl-property :major-version) - (gl-property :minor-version) - (profile context) - (gl-property :sample-buffers) - (gl-property :samples) - (gl-property :max-texture-size) - (gl-property :max-vertex-texture-image-units) - ;; Fuck you, GL, and your stupid legacy crap. - (gl-property :max-texture-image-units) - (gl-property :max-tess-control-texture-image-units) - (gl-property :max-tess-evaluation-texture-image-units) - (gl-property :max-geometry-texture-image-units) - (gl-property :max-compute-texture-image-units) - (when-gl-extension :GL-ARB-COMPUTE-SHADER - (append (coerce (gl-property :max-compute-work-group-count) 'list) - (coerce (gl-property :max-compute-work-group-size) 'list) - (list (gl-property :max-compute-work-group-invocations)))) - (gl-property :vendor) - (gl-property :renderer) - (gl-property :version) - (gl-property :shading-language-version) - (when show-extensions - (ignore-errors - (loop for i from 0 below (gl:get* :num-extensions) - collect (gl:get-string-i :extensions i)))))) - (defun context-note-debug-info (context) (v:debug :trial.context "Context information: ~a" (let ((*print-right-margin* 1000)) ; SBCL fails otherwise. Huh? (with-output-to-string (out) (context-info context :stream out))))) -(defmethod glsl-target-version ((context context)) - (let ((slot (slot-value context 'glsl-target-version))) - (or slot (format NIL "~{~d~d~}0" (version context))))) - -(defmethod glsl-version-header ((context context)) - (format NIL "#version ~a~@[ ~a~]" - (glsl-target-version context) - (case (profile context) - (:core "core") - (:es "es")))) - -(defmethod glsl-target-version ((default (eql T))) - (if *context* (glsl-target-version *context*) "330")) - (defmethod (setf icon) ((path pathname) (context context)) (multiple-value-bind (bits width height pixel-type pixel-format swizzle) (load-image path T) diff --git a/debug.lisp b/debug.lisp index 261423afb..8dc8a72e5 100644 --- a/debug.lisp +++ b/debug.lisp @@ -25,10 +25,8 @@ (setf (uniform program "view_matrix") (view-matrix)) (setf (uniform program "projection_matrix") (projection-matrix)) (setf (uniform program "texture_image") 0) - (gl:active-texture :texture0) - (gl:bind-texture :texture-2d (gl-name (// 'trial 'ascii))) - (gl:bind-vertex-array (gl-name (text-vao draw))) - (gl:draw-arrays :triangles 0 (truncate (length (text draw)) 5))) + (bind (// 'trial 'ascii) NIL) + (render (text-vao draw) (truncate (length (text draw)) 5))) (define-class-shader (debug-draw-text :vertex-shader) "layout (location = 0) in vec3 position; @@ -103,10 +101,8 @@ void main(){ (defmethod render ((draw debug-draw) (program shader-program)) (setf (uniform program "view_matrix") (view-matrix)) (setf (uniform program "projection_matrix") (projection-matrix)) - (gl:bind-vertex-array (gl-name (points-vao draw))) - (gl:draw-arrays :points 0 (truncate (length (points draw)) 6)) - (gl:bind-vertex-array (gl-name (lines-vao draw))) - (gl:draw-arrays :lines 0 (truncate (length (lines draw)) 6)) + (render (points-vao draw) (truncate (length (points draw)) 6)) + (render (lines-vao draw) (truncate (length (lines draw)) 6)) (render (text-render draw) T)) (defmacro define-debug-draw-function ((name type) args &body body) diff --git a/display.lisp b/display.lisp index e0d9ca749..9f2baeda7 100644 --- a/display.lisp +++ b/display.lisp @@ -39,26 +39,23 @@ (defmethod handle (event (display display))) (defmethod setup-rendering ((display display)) - (reset-matrix (model-matrix)) - (reset-matrix (view-matrix)) - (reset-matrix (projection-matrix)) - (reset-features (feature-table)) - (gl:stencil-mask #xFF) - (gl:clear-stencil #x00) - (gl:stencil-op :keep :keep :keep) - (gl:depth-mask T) - (gl:depth-func :lequal) - (gl:blend-func-separate :src-alpha :one-minus-src-alpha :one :one-minus-src-alpha) - #-arm64 (gl:clear-depth 1.0) - (gl:front-face :ccw) - (gl:cull-face :back) - (gl:pixel-store :unpack-alignment 1) - (gl:pixel-store :pack-alignment 1) - (with-vec (r g b a) (clear-color display) - (gl:clear-color r g b a)) - (enable-feature :blend :multisample :cull-face :stencil-test :depth-test :texture-cube-map-seamless) - (when-gl-extension :gl-arb-depth-clamp - (enable-feature :depth-clamp))) + (let ((context (context display))) + (reset-matrix (model-matrix)) + (reset-matrix (view-matrix)) + (reset-matrix (projection-matrix)) + (reset-features (feature-table)) + (setf (write-to-depth context) T) + (setf (depth-mode context) '<=) + (setf (stencil-mode context) '<=) + (setf (blend-mode context) :default) + (setf (culling-mode context) :default) + (setf (stencil-mode context) :default) + (setf (clear-color context (clear-color display))) + (gl:pixel-store :unpack-alignment 1) + (gl:pixel-store :pack-alignment 1) + (enable-feature :blend :multisample :cull-face :stencil-test :depth-test :texture-cube-map-seamless) + (when-gl-extension :gl-arb-depth-clamp + (enable-feature :depth-clamp)))) (defmethod update :after ((display display) tt dt fc) (declare (type double-float tt)) diff --git a/effects.lisp b/effects.lisp index f43b2619a..ff940a80f 100644 --- a/effects.lisp +++ b/effects.lisp @@ -47,13 +47,14 @@ void main(){ ((iterations :initarg :iterations :initform 1 :accessor iterations))) (defmethod render ((pass iterative-post-effect-pass) (program shader-program)) - (let* ((color (gl-name (color pass))) + (let* ((color (color pass)) (ocolor color) - (previous (gl-name (previous-pass pass)))) + (framebuffer (framebuffer pass)) + (previous (previous-pass pass))) (flet ((swap-buffers () (rotatef color previous) - (%gl:framebuffer-texture :framebuffer :color-attachment0 color 0) - (gl:bind-texture :texture-2d previous))) + (bind color framebuffer) + (bind previous 0))) (call-next-method) (loop with limit = (iterations pass) for i from 0 @@ -63,8 +64,8 @@ void main(){ (return))) ;; KLUDGE: this is wrong for even number of iterations. It essentially ;; discards the last iteration, as it won't be displayed.... - (when (/= ocolor color) - (%gl:framebuffer-texture :framebuffer :color-attachment0 ocolor 0))))) + (unless (eq ocolor color) + (bind ocolor (framebuffer pass)))))) (define-shader-pass temporal-post-effect-pass (post-effect-pass) ((previous :port-type static-input :accessor previous) @@ -72,7 +73,7 @@ void main(){ (defmethod render :after ((pass temporal-post-effect-pass) thing) (rotatef (gl-name (previous pass)) (gl-name (color pass))) - (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name (color pass)) 0)) + (bind (color pass) (framebuffer pass))) (define-shader-pass copy-pass (simple-post-effect-pass) ()) diff --git a/fps.lisp b/fps.lisp index 38cd73fcb..32093702f 100644 --- a/fps.lisp +++ b/fps.lisp @@ -67,8 +67,7 @@ for div = 1 then (* 10 div) do (set-rect i (mod (floor fps div) 10)))) (update-buffer-data buf T))) - (gl:active-texture :texture0) - (gl:bind-texture :texture-2d (gl-name (// 'trial 'fps-texture))) + (bind (// 'trial 'fps-texture) NIL) (render vao program))) (define-class-shader (fps-counter :vertex-shader) diff --git a/gl-features.lisp b/gl-features.lisp index 38748bdfd..9d7a70aa2 100644 --- a/gl-features.lisp +++ b/gl-features.lisp @@ -128,3 +128,243 @@ (unwind-protect (progn ,@body) (pop-features)))) + +(defclass gl-context (context) + ((glsl-target-version :initarg :glsl-version :initform NIL :accessor glsl-target-version)) + (:default-initargs + :version '(3 3) + :profile :core)) + +(defmethod create-context :after ((context glcontext)) + (cache-gl-extensions)) + +(defmethod glsl-target-version ((context gl-context)) + (let ((slot (slot-value context 'glsl-target-version))) + (or slot (format NIL "~{~d~d~}0" (version context))))) + +(defmethod glsl-version-header ((context gl-context)) + (format NIL "#version ~a~@[ ~a~]" + (glsl-target-version context) + (case (profile context) + (:core "core") + (:es "es")))) + +(defmethod glsl-target-version ((default (eql T))) + (if *context* (glsl-target-version *context*) "330")) + +(defmacro with-render-settings (settings &body body) + (let ((thunk (gensym "THUNK")) + (settings (loop for setting in settings + collect (etypecase setting + (keyword + (ecase setting + (:no-depth-writes `(write-to-depth-p T NIL)) + (:additive-blend `(blend-mode :additive NIL)) + (:front-cull `(cull-face :front :back)) + ;; Already defaults + ;; FIXME: make nested with-render-* actually do the right thing + (:depth-writes `(write-to-depth-p T T)) + (:source-blend `(blend-mode NIL NIL)) + (:back-cull `(cull-face :back :back)))) + (cons + ))))) + `(flet ((,thunk () ,@body)) + ,@(loop for (func on off) in settings + unless (eql on '_) collect `(setf (,func *context*) ,on)) + (multiple-value-prog1 + (,thunk) + ,@(loop for (func on off) in settings + unless (eql off '_) collect `(setf (,func *context*) ,off)))))) + +(defmethod (setf write-to-depth) (mask (context gl-context)) + (gl:depth-mask mask)) + +(defmethod (setf depth-mode) (mode (context gl-context)) + (ecase mode + ((NIL) (gl:depth-func :never)) + ((T) (gl:depth-func :always)) + (= (gl:depth-func :equal)) + (/= (gl:depth-func :notequal)) + (<= (gl:depth-func :lequal)) + (>= (gl:depth-func :lequal)) + (< (gl:depth-func :less)) + (> (gl:depth-func :greater)))) + +(defmethod (setf blend-mode) (mode (context gl-context)) + (ecase mode + (:additive + (gl:blend-func :src-alpha :one)) + ((NIL :default :source-over) + (gl:blend-func-separate :src-alpha :one-minus-src-alpha :one :one-minus-src-alpha)))) + +(defmethod (setf culling-mode) (mode (context gl-context)) + (ecase mode + ((NIL) (disable-feature :cull-face)) + ((T) (enable-feature :cull-face)) + ((:default :back-faces) (gl:cull-face :back)) + (:front-faces (gl:cull-face :front)))) + +(defmethod (setf stencil-mode) (mode (context gl-context)) + (ecase mode + ((NIL) + (gl:stencil-func :never 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + ((T) + (gl:stencil-func :always 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (= + (gl:stencil-func :equal 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (/= + (gl:stencil-func :notequal 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + ((<= :default) + (gl:stencil-func :lequal 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (>= + (gl:stencil-func :gequal 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (< + (gl:stencil-func :greater 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (> + (gl:stencil-func :less 127 #xFFFFFF) + (gl:stencil-op :keep :keep :keep)) + (1+ + (gl:stencil-func :always 127 #xFFFFFF) + (gl:stencil-op :keep :keep :incr)) + (1- + (gl:stencil-func :always 127 #xFFFFFF) + (gl:stencil-op :keep :keep :decr)) + (clear + (gl:stencil-func :always 127 #xFFFFFF) + (gl:stencil-op :keep :keep :replace)) + (T + (gl:stencil-func :always mode #xFFFFFF) + (gl:stencil-op :keep :keep :replace)))) + +(defmethod (setf clear-color) ((vec vec3) (context gl-context)) + (gl:clear-color (vx3 vec) (vy3 vec) (vz3 vec) 1.0)) + +(defmethod (setf clear-color) ((vec vec4) (context gl-context)) + (gl:clear-color (vx4 vec) (vy4 vec) (vz4 vec) (vw4 vec))) + +(defmethod (setf clear-color) ((int integer) (context gl-context)) + (let ((r (ldb (byte 8 0) int)) + (g (ldb (byte 8 8) int)) + (b (ldb (byte 8 16) int)) + (a (ldb (byte 8 24) int))) + (gl:clear-color (/ r 255.0) (/ g 255.0) (/ b 255.0) (/ a 255.0)))) + +;; https://www.khronos.org/registry/OpenGL/extensions/ATI/ATI_meminfo.txt +(defun %gl-gpu-room-ati () + (let* ((vbo-free-memory-ati (gl:get-integer #x87FB 4)) + (tex-free-memory-ati (gl:get-integer #x87FC 4)) + (buf-free-memory-ati (gl:get-integer #x87FD 4)) + (total (+ (aref vbo-free-memory-ati 0) + (aref tex-free-memory-ati 0) + (aref buf-free-memory-ati 0)))) + (values total total))) + +;; http://developer.download.nvidia.com/opengl/specs/GL_NVX_gpu_memory_info.txt +(defun %gl-gpu-room-nvidia () + (let ((vidmem-total (gl:get-integer #x9047 1)) + (vidmem-free (gl:get-integer #x9049 1))) + (values vidmem-free + vidmem-total))) + +(defmethod gpu-room ((context gl-context)) + (macrolet ((jit (thing) + `(ignore-errors + (return-from gpu-room + (multiple-value-prog1 ,thing + (compile 'gpu-room (lambda () + ,thing))))))) + (jit (%gl-gpu-room-ati)) + (jit (%gl-gpu-room-nvidia)) + (jit (values 1 1)))) + +(defmethod max-texture-id ((context gl-context)) + (gl:get-integer :max-texture-image-units)) + +(define-global +gl-extensions+ ()) + +(defun cache-gl-extensions () + (let ((*package* (find-package "KEYWORD"))) + (setf +gl-extensions+ + (loop for i from 0 below (gl:get* :num-extensions) + for name = (ignore-errors (gl:get-string-i :extensions i)) + when name + collect (cffi:translate-name-from-foreign name *package*))))) + +(defun gl-extension-p (extension) + (find extension +gl-extensions+)) + +(defun list-gl-extensions () + (or +gl-extensions* + (cache-gl-extensions))) + +(defmacro when-gl-extension (extension &body body) + (let ((list (enlist extension))) + ;; TODO: Optimise this by caching the test after first runtime. + `(when (and ,@(loop for extension in list + collect `(find ,extension +gl-extensions+))) + ,@body))) + +(defmacro gl-extension-case (&body cases) + `(cond ,@(loop for (extensions . body) in cases + collect (case extensions + ((T otherwise) + `(T ,@body)) + (T + `((and ,@(loop for extension in (enlist extensions) + collect `(find ,extension +gl-extensions+))) + ,@body)))))) + +(defun gl-property (name) + (handler-case (gl:get* name) + (error (err) (declare (ignore err)) + :unavailable))) + +(defun gl-vendor () + (let ((vendor (gl:get-string :vendor))) + (cond ((search "Intel" vendor) :intel) + ((search "NVIDIA" vendor) :nvidia) + ((search "ATI" vendor) :amd) + ((search "AMD" vendor) :amd) + (T :unknown)))) + +(defmethod context-info ((context gl-context) &key (stream *standard-output*) (show-extensions T)) + (format stream "~&~%Running GL~a.~a ~a~%~ + Sample buffers: ~a (~a sample~:p)~%~ + Max texture size: ~a~%~ + Max texture units: ~a ~a ~a ~a ~a ~a~%~ + ~@[~{Max compute groups: ~a ~a ~a~%~ + Max work groups: ~a ~a ~a (~a)~%~}~]~ + GL Vendor: ~a~%~ + GL Renderer: ~a~%~ + GL Version: ~a~%~ + GL Shader Language: ~a~%~ + ~@[GL Extensions: ~{~a~^ ~}~%~]" + (gl-property :major-version) + (gl-property :minor-version) + (profile gl-context) + (gl-property :sample-buffers) + (gl-property :samples) + (gl-property :max-texture-size) + (gl-property :max-vertex-texture-image-units) + ;; Fuck you, GL, and your stupid legacy crap. + (gl-property :max-texture-image-units) + (gl-property :max-tess-control-texture-image-units) + (gl-property :max-tess-evaluation-texture-image-units) + (gl-property :max-geometry-texture-image-units) + (gl-property :max-compute-texture-image-units) + (when-gl-extension :GL-ARB-COMPUTE-SHADER + (append (coerce (gl-property :max-compute-work-group-count) 'list) + (coerce (gl-property :max-compute-work-group-size) 'list) + (list (gl-property :max-compute-work-group-invocations)))) + (gl-property :vendor) + (gl-property :renderer) + (gl-property :version) + (gl-property :shading-language-version) + (when show-extensions (list-gl-extensions)))) diff --git a/helpers.lisp b/helpers.lisp index 76f302572..ba9aa18b8 100644 --- a/helpers.lisp +++ b/helpers.lisp @@ -196,8 +196,7 @@ void main(){ (stage (texture entity) area)) (defmethod bind-textures :after ((obj textured-entity)) - (%gl:active-texture :texture0) - (gl:bind-texture (target (texture obj)) (gl-name (texture obj)))) + (bind (texture obj) NIL)) (define-class-shader (textured-entity :vertex-shader) "layout (location = 2) in vec2 in_uv; diff --git a/main.lisp b/main.lisp index 961f43bd8..4ba916860 100644 --- a/main.lisp +++ b/main.lisp @@ -29,35 +29,13 @@ (setf +main+ NIL) (setf +input-source+ :keyboard)) -#+windows -(cffi:define-foreign-library secur32 - (T (:default "Secur32"))) - -(flet ((fallback-username () - (or - #+windows - (cffi:with-foreign-objects ((size :ulong) - (name :uint16 128)) - (unless (cffi:foreign-library-loaded-p 'secur32) - (cffi:load-foreign-library 'secur32)) - (setf (cffi:mem-ref size :ulong) 128) - ;; Constant 3 here specifies a "display name". - (cond ((< 0 (cffi:foreign-funcall "GetUserNameExW" :int 13 :pointer name :pointer size :int)) - (org.shirakumo.com-on:wstring->string name (cffi:mem-ref size :ulong))) - (T - (setf (cffi:mem-ref size :ulong) 128) - (when (< 0 (cffi:foreign-funcall "GetUserNameW" :pointer name :pointer size :int)) - (org.shirakumo.com-on:wstring->string name (cffi:mem-ref size :ulong)))))) - #+unix - (cffi:foreign-funcall "getlogin" :string) - (pathname-utils:directory-name (user-homedir-pathname))))) - (defmethod username ((main main)) - (fallback-username)) - - (defmethod username ((default (eql T))) - (if +main+ - (username +main+) - (fallback-username)))) +(defmethod username ((main main)) + (fallback-username)) + +(defmethod username ((default (eql T))) + (if +main+ + (username +main+) + (fallback-username))) (defmethod scene ((default (eql T))) (scene +main+)) diff --git a/os-resources.lisp b/os-resources.lisp index 1b1643dca..baae53b1c 100644 --- a/os-resources.lisp +++ b/os-resources.lisp @@ -82,36 +82,31 @@ #-(or linux windows) (defun cpu-time () 0d0) -;; https://www.khronos.org/registry/OpenGL/extensions/ATI/ATI_meminfo.txt -(defun gpu-room-ati () - (let* ((vbo-free-memory-ati (gl:get-integer #x87FB 4)) - (tex-free-memory-ati (gl:get-integer #x87FC 4)) - (buf-free-memory-ati (gl:get-integer #x87FD 4)) - (total (+ (aref vbo-free-memory-ati 0) - (aref tex-free-memory-ati 0) - (aref buf-free-memory-ati 0)))) - (values total total))) - -;; http://developer.download.nvidia.com/opengl/specs/GL_NVX_gpu_memory_info.txt -(defun gpu-room-nvidia () - (let ((vidmem-total (gl:get-integer #x9047 1)) - (vidmem-free (gl:get-integer #x9049 1))) - (values vidmem-free - vidmem-total))) - -(defun gpu-room () - (macrolet ((jit (thing) - `(ignore-errors - (return-from gpu-room - (multiple-value-prog1 ,thing - (compile 'gpu-room (lambda () - ,thing))))))) - (jit (gpu-room-ati)) - (jit (gpu-room-nvidia)) - (jit (values 1 1)))) - (defun cpu-room () #+sbcl (values (round (- (sb-ext:dynamic-space-size) (sb-kernel:dynamic-usage)) 1024.0) (round (sb-ext:dynamic-space-size) 1024.0)) #-sbcl (values 1 1)) + +#+windows +(cffi:define-foreign-library secur32 + (T (:default "Secur32"))) + +(defun fallback-username () + (or + #+windows + (cffi:with-foreign-objects ((size :ulong) + (name :uint16 128)) + (unless (cffi:foreign-library-loaded-p 'secur32) + (cffi:load-foreign-library 'secur32)) + (setf (cffi:mem-ref size :ulong) 128) + ;; Constant 3 here specifies a "display name". + (cond ((< 0 (cffi:foreign-funcall "GetUserNameExW" :int 13 :pointer name :pointer size :int)) + (org.shirakumo.com-on:wstring->string name (cffi:mem-ref size :ulong))) + (T + (setf (cffi:mem-ref size :ulong) 128) + (when (< 0 (cffi:foreign-funcall "GetUserNameW" :pointer name :pointer size :int)) + (org.shirakumo.com-on:wstring->string name (cffi:mem-ref size :ulong)))))) + #+unix + (cffi:foreign-funcall "getlogin" :string) + (pathname-utils:directory-name (user-homedir-pathname)))) diff --git a/parallax.lisp b/parallax.lisp index 56ca4e064..2260e5640 100644 --- a/parallax.lisp +++ b/parallax.lisp @@ -31,11 +31,8 @@ :offset (vec 0 0) :parallax (vec 2 2))))) (setf (uniform program "view_matrix") (minv *view-matrix*)) - (gl:active-texture :texture0) - (gl:bind-texture :texture-2d (gl-name (texture parallax-background))) - (gl:bind-vertex-array (gl-name (// 'trial:trial 'trial::empty-vertex-array))) - (gl:draw-arrays :triangle-strip 0 4) - (gl:bind-vertex-array 0)) + (bind (texture parallax-background) NIL) + (render (// 'trial:trial 'trial::empty-vertex-array) NIL)) (defmethod handle ((ev resize) (parallax-background parallax-background)) (with-buffer-tx (bg (// 'trial 'parallax)) diff --git a/pixel-pipeline.lisp b/pixel-pipeline.lisp index 3054da097..8b94130d3 100644 --- a/pixel-pipeline.lisp +++ b/pixel-pipeline.lisp @@ -68,20 +68,19 @@ ,@(when iterate (destructuring-bind (times (a b)) iterate `((defmethod render ((pass ,name) (program shader-program)) - (let ((in (gl-name (slot-value pass ',a))) - (out (gl-name (slot-value pass ',b))) + (let ((in (slot-value pass ',a)) + (out (slot-value pass ',b)) (unit-id (unit-id (port pass ',a))) (attachment (attachment (port pass ',b))) (times ,times)) - (gl:active-texture unit-id) (dotimes (i times) (call-next-method) (when (< i (1- times)) (rotatef in out) - (%gl:bind-texture :texture-2d in) - (%gl:framebuffer-texture :framebuffer attachment out 0))) - (setf (gl-name (slot-value pass ',a)) in) - (setf (gl-name (slot-value pass ',b)) out)))))))))) + (bind in unit-id) + (bind out framebuffer))) + (setf (gl-name (slot-value pass ',a)) (gl-name in)) + (setf (gl-name (slot-value pass ',b)) (gl-name out))))))))))) (defclass pixel-pipeline (pipeline) ((width :initarg :width :accessor width) @@ -177,13 +176,11 @@ (setf (dirty-p pipeline) NIL)) (let ((in (aref (passes pipeline) 0)) (out (aref (passes pipeline) (1- (length (passes pipeline)))))) - (%gl:bind-framebuffer :framebuffer (gl-name (framebuffer out))) + (activate (framebuffer out)) ,@(loop for (out in) in loopback collect `(rotatef (gl-name (slot-value in ',in)) (gl-name (slot-value out ',out))) - collect `(%gl:framebuffer-texture - :framebuffer (attachment (port out ',out)) - (gl-name (slot-value out ',out)) 0)))) + collect `(bind (slot-value out ',out) (framebuffer out))))) ,@(loop for (kind name type . args) in slots when (eql :uniform kind) diff --git a/renderer/particle.lisp b/renderer/particle.lisp index baf045272..29aef3466 100644 --- a/renderer/particle.lisp +++ b/renderer/particle.lisp @@ -384,14 +384,12 @@ (setf (emit-count struct) to-emit) (setf (randomness struct) (random 1.0))) ;; Simulate with compute shaders - (%gl:bind-buffer :dispatch-indirect-buffer (gl-name particle-argument-buffer)) - (render kickoff-pass NIL) - (render emit-pass NIL) + (render kickoff-pass particle-argument-buffer) + (render emit-pass 0) (simulate-particles particle-emitter) ;; Swap the buffers (rotatef (binding-point alive-particle-buffer-0) (binding-point alive-particle-buffer-1)) - (%gl:bind-buffer :dispatch-indirect-buffer 0) (setf (to-emit particle-emitter) emit-carry)))) (define-handler (particle-emitter class-changed) () @@ -404,24 +402,16 @@ (setf (slot-value struct 'dead-count) (max-particles emitter)))) (defmethod bind-textures ((emitter particle-emitter)) - (gl:active-texture :texture0) - (gl:bind-texture (target (texture emitter)) (gl-name (texture emitter)))) + (bind (texture emitter) 0)) (defmethod render :before ((emitter particle-emitter) (program shader-program)) - (gl:depth-mask NIL) - (setf (uniform program "model_matrix") (tmat4 (tf emitter))) - (gl:bind-vertex-array (gl-name (// 'trial 'empty-vertex-array))) - (%gl:bind-buffer :draw-indirect-buffer (gl-name (slot-value emitter 'particle-argument-buffer)))) - -(defmethod render :after ((emitter particle-emitter) (program shader-program)) - (gl:bind-vertex-array 0) - (%gl:bind-buffer :draw-indirect-buffer 0) - (gl:depth-mask T)) + (setf (uniform program "model_matrix") (tmat4 (tf emitter)))) (defmethod render ((emitter particle-emitter) (program shader-program)) - (gl:blend-func :src-alpha :one) - (%gl:draw-arrays-indirect :triangles (slot-offset 'particle-argument-buffer 'draw-args)) - (gl:blend-func-separate :src-alpha :one-minus-src-alpha :one :one-minus-src-alpha)) + (setf (offset (// 'trial 'empty-vertex-array)) (slot-offset 'particle-argument-buffer 'draw-args)) + (with-render-settings (:additive-blend :no-depth-writes) + (render (// 'trial 'empty-vertex-array) (slot-value emitter 'particle-argument-buffer))) + (setf (offset (// 'trial 'empty-vertex-array)) 0)) (defmethod emit ((particle-emitter particle-emitter) count &rest particle-options &key vertex-array location orientation scaling transform) ;; We do the emit **right now** so that the particle options are only active for the @@ -437,10 +427,8 @@ (with-buffer-tx (struct particle-emitter-buffer) (setf (emit-count struct) count) (setf (randomness struct) (random 1.0))) - (%gl:bind-buffer :dispatch-indirect-buffer (gl-name particle-argument-buffer)) - (render kickoff-pass NIL) - (render emit-pass NIL) - (%gl:bind-buffer :dispatch-indirect-buffer 0))) + (render kickoff-pass (gl-name particle-argument-buffer)) + (render emit-pass NIL))) (define-shader-pass depth-colliding-particle-simulate-pass (particle-simulate-pass) ((depth-tex :port-type fixed-input :accessor depth) @@ -548,7 +536,10 @@ until (< alive sorted)))))) (defmethod render ((emitter sorted-particle-emitter) (program shader-program)) - (%gl:draw-arrays-indirect :triangles (slot-offset 'particle-argument-buffer 'draw-args))) + (setf (offset (// 'trial 'empty-vertex-array)) (slot-offset 'particle-argument-buffer 'draw-args)) + (with-render-settings (:no-depth-writes) + (render (// 'trial 'empty-vertex-array) (slot-value emitter 'particle-argument-buffer))) + (setf (offset (// 'trial 'empty-vertex-array)) 0)) (define-shader-entity multi-texture-particle-emitter (particle-emitter) () diff --git a/renderer/pbr.lisp b/renderer/pbr.lisp index d0ef8288e..ed42e3a20 100644 --- a/renderer/pbr.lisp +++ b/renderer/pbr.lisp @@ -106,7 +106,7 @@ (setf (uniform program "brdf_lut") (local-id (// 'trial 'brdf-lut) pass))) (T ;; KLUDGE: Just set them to bogus values to get the AMD driver to shut up. - (let ((max (1- (gl:get-integer :max-combined-texture-image-units)))) + (let ((max (1- (max-texture-id *context*)))) (setf (uniform program "irradiance_map") max) (setf (uniform program "environment_map") max)) (setf (uniform program "brdf_lut") 0)))) diff --git a/renderer/shadow-map.lisp b/renderer/shadow-map.lisp index a0a943b56..a4fea9868 100644 --- a/renderer/shadow-map.lisp +++ b/renderer/shadow-map.lisp @@ -156,7 +156,7 @@ (defmethod render-frame :before ((pass standard-shadows-pass) frame) (let ((program (shadow-map-program pass)) - (map (gl-name (shadow-map pass))) + (map (shadow-map pass)) (lights (shadow-map-lights pass))) (activate (shadow-map-framebuffer pass)) (activate program) @@ -168,8 +168,8 @@ (dotimes (id (length lights)) (when (aref lights id) (setf (uniform program "shadow_map_id") id) - (%gl:framebuffer-texture-layer :framebuffer :depth-attachment map 0 id) - (gl:clear :depth-buffer) + (bind map (shadow-map-framebuffer pass)) + (clear (shadow-map-framebuffer pass)) (loop for (object) across frame do (when (typep object 'standard-renderable) (with-pushed-matrix () diff --git a/renderer/standard-renderer.lisp b/renderer/standard-renderer.lisp index 4877a7b50..6b327d2b4 100644 --- a/renderer/standard-renderer.lisp +++ b/renderer/standard-renderer.lisp @@ -44,7 +44,7 @@ (setf (slot-value pass 'light-block) (make-instance 'uniform-buffer :binding NIL :struct (make-instance 'standard-light-block :size max-lights)))) (defmethod shared-initialize :after ((pass standard-render-pass) slots &key) - (let ((max-textures (max 16 (if *context* (gl:get-integer :max-texture-image-units) 256)))) + (let ((max-textures (max 16 (if *context* (max-texture-id *context*) 256)))) (dolist (port (flow:ports pass)) (typecase port (texture-port @@ -93,8 +93,7 @@ (defmethod bind-textures ((pass standard-render-pass)) (call-next-method) (do-lru-cache (texture id (allocated-textures pass)) - (gl:active-texture id) - (gl:bind-texture (target texture) (gl-name texture)))) + (bind texture id))) (defmethod enable ((texture texture) (pass standard-render-pass)) ;; KLUDGE: We effectively disable the cache here BECAUSE the texture binds are @@ -105,8 +104,7 @@ (let ((id (or (lru-cache-push texture (allocated-textures pass)) (lru-cache-id texture (allocated-textures pass))))) (when id - (gl:active-texture id) - (gl:bind-texture (target texture) (gl-name texture))))) + (bind texture id)))) (defmethod disable ((texture texture) (pass standard-render-pass)) (lru-cache-pop texture (allocated-textures pass))) diff --git a/resources/compute-shader.lisp b/resources/compute-shader.lisp index e10017338..9b1605780 100644 --- a/resources/compute-shader.lisp +++ b/resources/compute-shader.lisp @@ -9,12 +9,29 @@ (defclass compute-shader (shader-program) ((shader-source :initarg :source :initform (arg! :source) :accessor shader-source) (shaders :initform ()) - (workgroup-size :initarg :workgroup-size :initform (vec 1 1 1) :accessor workgroup-size))) + (work-groups :initarg :work-groups :initform (vec 1 1 1) :accessor work-groups) + (barrier :initform 4294967295))) + +(defmethod initialize-instance :after ((shader compute-shader) &key) + (unless (integerp (slot-value shader 'barrier)) + (setf (barrier shader) (slot-value shader 'barrier)))) + +(defmethod shared-initialize :after ((shader compute-shader) slots &key (barrier NIL barrier-p)) + (when barrier-p (setf (barrier shader) barrier))) (defmethod print-object ((shader compute-shader) stream) (print-unreadable-object (shader stream :type T :identity T) (format stream "~:[~;ALLOCATED~]" (allocated-p shader)))) +(defmethod barrier ((shader compute-shader)) + (cffi:foreign-bitfield-symbols '%gl::MemoryBarrierMask (slot-value shader 'barrier))) + +(defmethod (setf barrier) ((bits list) (shader compute-shader)) + (setf (slot-value shader 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask bits))) + +(defmethod (setf barrier) ((bits symbol) (shader compute-shader)) + (setf (slot-value shader 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask (list bits)))) + (defmethod allocate ((shader compute-shader)) (let ((source (shader-source shader)) (shdr (gl:create-shader :compute-shader)) @@ -28,7 +45,7 @@ (when (eql :es (profile *context*)) (setf source (glsl-toolkit:transform source :es (version *context*))))) (gl:shader-source shdr source) - (gl:compile-shader shdr) + (gl:compile-shader shdr)2 (unless (gl:get-shader shdr :compile-status) (error 'shader-compilation-error :shader shader :log (gl:get-shader-info-log shdr))) (v:debug :trial.asset "Compiled shader ~a: ~%~a" shader source) @@ -36,7 +53,39 @@ (gl:delete-shader shdr) (setf (data-pointer shader) prog))))) -(defmethod activate ((shader compute-shader)) - (call-next-method) - (let ((size (workgroup-size shader))) - (%gl:dispatch-compute (truncate (vx size)) (truncate (vy size)) (truncate (vz size))))) +(defmethod render ((shader compute-shader) (target null)) + (let ((work-groups (work-groups shader)) + (barrier (slot-value shader 'barrier))) + (etypecase work-groups + (vec3 + (%gl:dispatch-compute + (truncate (vx work-groups)) + (truncate (vy work-groups)) + (truncate (vz work-groups)))) + (integer + (%gl:dispatch-compute-indirect work-groups)) + (buffer-object + (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups)) + (%gl:dispatch-compute-indirect 0))) + (when (/= 0 barrier) + (%gl:memory-barrier barrier)))) + +(defmethod render ((shader compute-shader) (offset integer)) + (let ((work-groups (work-groups shader)) + (barrier (slot-value shader 'barrier))) + (etypecase work-groups + (buffer-object + (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups)) + (%gl:dispatch-compute-indirect offset))) + (when (/= 0 barrier) + (%gl:memory-barrier barrier)))) + +(defmethod render ((shader compute-shader) (target buffer-object)) + (let ((work-groups (work-groups shader)) + (barrier (slot-value shader 'barrier))) + (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups)) + (%gl:dispatch-compute-indirect (etypecase work-groups + (integer work-groups) + (null 0))) + (when (/= 0 barrier) + (%gl:memory-barrier barrier)))) diff --git a/resources/framebuffer.lisp b/resources/framebuffer.lisp index c2829c897..237dc9f97 100644 --- a/resources/framebuffer.lisp +++ b/resources/framebuffer.lisp @@ -29,6 +29,18 @@ (append (call-next-method) (mapcar #'second (attachments framebuffer)))) +(defun check-framebuffer-size (framebuffer texture) + (cond ((null (width framebuffer)) + (setf (width framebuffer) (width texture))) + ((/= (width framebuffer) (width texture)) + (error "Cannot attach~% ~a~%to~% ~a~%, as the width is mismatched." + texture framebuffer))) + (cond ((null (height framebuffer)) + (setf (height framebuffer) (height texture))) + ((/= (height framebuffer) (height texture)) + (error "Cannot attach~% ~a~%to~% ~a~%, as the height is mismatched." + texture framebuffer)))) + (defun bind-framebuffer-attachments (framebuffer attachments) (let ((color-attachments (loop for attachment in attachments unless (find (first attachment) '(:depth-attachment :stencil-attachment :depth-stencil-attachment)) @@ -42,18 +54,9 @@ (check-framebuffer-attachment attachment) (check-type texture texture) (check-allocated texture) + (check-framebuffer-size framebuffer texture) (v:debug :trial.framebuffer "Attaching ~a~@[:~a~] as ~a to ~a." texture layer attachment framebuffer) - (cond ((null (width framebuffer)) - (setf (width framebuffer) (width texture))) - ((/= (width framebuffer) (width texture)) - (error "Cannot attach~% ~a~%to~% ~a~%, as the width is mismatched." - texture framebuffer))) - (cond ((null (height framebuffer)) - (setf (height framebuffer) (height texture))) - ((/= (height framebuffer) (height texture)) - (error "Cannot attach~% ~a~%to~% ~a~%, as the height is mismatched." - texture framebuffer))) (if layer (%gl:framebuffer-texture-layer :framebuffer attachment (gl-name texture) level layer) (%gl:framebuffer-texture :framebuffer attachment (gl-name texture) level)) @@ -78,6 +81,19 @@ (with-cleanup-on-failure (bind-framebuffer-attachments framebuffer (attachments framebuffer)) (bind-framebuffer-attachments framebuffer attachments)))) +(defmethod bind ((texture texture) (framebuffer framebuffer)) + (check-framebuffer-size framebuffer texture) + (gl:bind-framebuffer (gl-name framebuffer)) + (case (internal-format texture) + ((:depth-component :depth-component16 :depth-component24 :depth-component32 :depth-component32f) + (%gl:framebuffer-texture :framebuffer :depth-attachment (gl-name texture) 0)) + ((:stencil-index :stencil-index1 :stencil-index4 :stencil-index8 :stencil-index16) + (%gl:framebuffer-texture :framebuffer :stencil-attachment (gl-name texture) 0)) + ((:depth-stencil :depth24-stencil8 :depth32f-stencil8) + (%gl:framebuffer-texture :framebuffer :depth-stencil-attachment (gl-name texture) 0)) + (T + (%gl:framebuffer-texture :framebuffer :color-attachment0 (gl-name texture) 0)))) + (defmethod allocate ((framebuffer framebuffer)) (let ((fbo (gl:gen-framebuffer))) (with-cleanup-on-failure (gl:delete-framebuffers (list fbo)) @@ -95,20 +111,37 @@ (setf (width framebuffer) width) (setf (height framebuffer) height))) +;; TODO: avoid rebinding framebuffer if already bound (defmethod activate ((framebuffer framebuffer)) (gl:bind-framebuffer :framebuffer (gl-name framebuffer)) (gl:viewport 0 0 (width framebuffer) (height framebuffer)) (let ((bits (slot-value framebuffer 'clear-bits))) (when (< 0 bits) (%gl:clear bits)))) -;; FIXME: this should ideally be more generic, with blitting from one to another framebuffer -;; and handling the screen as a special framebuffer instance that's always around. +(defmethod clear ((framebuffer framebuffer)) + (gl:bind-framebuffer :framebuffer (gl-name framebuffer)) + (let ((bits (slot-value framebuffer 'clear-bits))) + (when (< 0 bits) (%gl:clear bits)))) + +(defmethod render ((source framebuffer) (target integer)) + (gl:bind-framebuffer :read-framebuffer (gl-name source)) + (gl:bind-framebuffer :draw-framebuffer target) + (%gl:blit-framebuffer 0 0 (trial:width source) (trial:height source) + 0 0 (trial:width source) (trial:height source) + '(:color-buffer :depth-buffer :stencil-buffer) :linear)) + +(defmethod render ((source framebuffer) (target framebuffer)) + (gl:bind-framebuffer :read-framebuffer (gl-name source)) + (gl:bind-framebuffer :draw-framebuffer (gl-name target)) + (%gl:blit-framebuffer 0 0 (trial:width source) (trial:height source) + 0 0 (trial:width target) (trial:height target) + '(:color-buffer :depth-buffer :stencil-buffer) :linear)) + +(defmethod render ((source framebuffer) (target null)) + (render source 0)) + (defmethod blit-to-screen ((framebuffer framebuffer)) - (gl:bind-framebuffer :read-framebuffer (gl-name framebuffer)) - (gl:bind-framebuffer :draw-framebuffer 0) - (%gl:blit-framebuffer 0 0 (width framebuffer) (height framebuffer) 0 0 (width *context*) (height *context*) - (cffi:foreign-bitfield-value '%gl::ClearBufferMask :color-buffer) - (cffi:foreign-enum-value '%gl:enum :nearest))) + (render framebuffer 0)) (defgeneric capture (thing &key &allow-other-keys)) (defmethod capture ((framebuffer framebuffer) &key (x 0) (y 0) (width (width framebuffer)) (height (height framebuffer)) diff --git a/resources/shader-program.lisp b/resources/shader-program.lisp index cc7a1f939..e76b4ab04 100644 --- a/resources/shader-program.lisp +++ b/resources/shader-program.lisp @@ -216,6 +216,7 @@ :location (uniform-location program name)))))) (defmethod activate ((program shader-program)) + ;; FIXME: BAD leakage between runs. Bind to context instead. (unless (eq +current-shader-program+ program) (setf +current-shader-program+ program) (gl:use-program (gl-name program)))) diff --git a/resources/texture.lisp b/resources/texture.lisp index ab3622528..0973eb543 100644 --- a/resources/texture.lisp +++ b/resources/texture.lisp @@ -284,6 +284,14 @@ (%gl:get-tex-image (target source) level format type (memory-region-pointer region)) (apply #'save-image region target type :width (width source) :height (height source) :pixel-type type :pixel-format format args)))) +(defmethod bind ((texture texture) (port null)) + (gl:active-texture :texture0) + (gl:bind-texture (target texture) (gl-name texture))) + +(defmethod bind ((texture texture) (port integer)) + (gl:active-texture port) + (gl:bind-texture (target texture) (gl-name texture))) + ;;;; Texture spec wrangling ;; The idea of this is that, in order to maximise sharing of texture resources ;; between independent parts, we need to join (in the lattice sense) two texture diff --git a/resources/vertex-array.lisp b/resources/vertex-array.lisp index 94106eaa0..c86774052 100644 --- a/resources/vertex-array.lisp +++ b/resources/vertex-array.lisp @@ -10,6 +10,7 @@ ((size :initarg :size :initform NIL :accessor size) (bindings :initarg :bindings :accessor bindings) (vertex-form :initarg :vertex-form :accessor vertex-form) + (offset :initform 0 :initarg :offset :accessor offset) (index-buffer :initform NIL :accessor index-buffer :reader indexed-p)) (:default-initargs :bindings (error "BINDINGS required.") @@ -102,8 +103,22 @@ (declare (type (unsigned-byte 32) size)) (gl:bind-vertex-array (gl-name array)) (if (indexed-p array) - (%gl:draw-elements (vertex-form array) size (element-type (indexed-p array)) 0) - (%gl:draw-arrays (vertex-form array) 0 size)) - #++ - (%gl:draw-arrays (vertex-form array) 0 size) + (%gl:draw-elements (vertex-form array) size (element-type (indexed-p array)) (offset array)) + (%gl:draw-arrays (vertex-form array) (offset array) size)) (gl:bind-vertex-array 0))) + +(defmethod render ((array vertex-array) (offset integer)) + (let* ((size (size array))) + (declare (type (unsigned-byte 32) size)) + (gl:bind-vertex-array (gl-name array)) + (if (indexed-p array) + (%gl:draw-elements (vertex-form array) size (element-type (indexed-p array)) offset) + (%gl:draw-arrays (vertex-form array) offset size)) + (gl:bind-vertex-array 0))) + +(defmethod render ((array vertex-array) (buffer buffer-object)) + (%gl:bind-buffer :draw-indirect-buffer (gl-name buffer)) + (gl:bind-vertex-array (gl-name array)) + (%gl:draw-arrays-indirect :triangles (offset array)) + (gl:bind-vertex-array 0) + (%gl:bind-buffer :draw-indirect-buffer 0)) diff --git a/shader-pass.lisp b/shader-pass.lisp index c1ed40187..502c882ba 100644 --- a/shader-pass.lisp +++ b/shader-pass.lisp @@ -113,7 +113,7 @@ (:inhibit-shaders (shader-entity :fragment-shader))) (defmethod shared-initialize :after ((pass shader-pass) slots &key) - (loop with texture-index = (max 16 (gl:get-integer :max-texture-image-units)) + (loop with texture-index = (if *context* (max-texture-id *context*) 16) for port in (flow:ports pass) do (typecase port (texture-port @@ -231,8 +231,7 @@ (typecase port (uniform-port (when (texture port) - (gl:active-texture (unit-id port)) - (gl:bind-texture (target (texture port)) (gl-name (texture port))))) + (bind (texture port) (unit-id port)))) (image-port (when (texture port) (%gl:bind-image-texture (binding port) (gl-name (texture port)) 0 T 0 (access port) @@ -491,49 +490,19 @@ void main(){ color = texture(previous_pass, uv); }") -(define-shader-pass compute-pass (single-shader-pass) - ((work-groups :initform (vec 1 1 1) :initarg :work-groups :accessor work-groups) - (barrier :initform 4294967295))) - -(defmethod initialize-instance :after ((pass compute-pass) &key) - (unless (integerp (slot-value pass 'barrier)) - (setf (barrier pass) (slot-value pass 'barrier)))) - -(defmethod shared-initialize :after ((pass compute-pass) slots &key (barrier NIL barrier-p)) - (when barrier-p (setf (barrier pass) barrier))) +(define-shader-pass compute-pass (single-shader-pass compute-shader) + ()) (defmethod handle ((event event) (pass compute-pass))) -(defmethod barrier ((pass compute-pass)) - (cffi:foreign-bitfield-symbols '%gl::MemoryBarrierMask (slot-value pass 'barrier))) +(defmethod shader-program ((pass compute-pass)) + pass) -(defmethod (setf barrier) ((bits list) (pass compute-pass)) - (setf (slot-value pass 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask bits))) +(defmethod shaders ((pass compute-pass)) + (shaders (make-shader-program pass))) -(defmethod (setf barrier) ((bits symbol) (pass compute-pass)) - (setf (slot-value pass 'barrier) (cffi:foreign-bitfield-value '%gl::MemoryBarrierMask (list bits)))) - -(defmethod render ((pass compute-pass) (_ null)) - (bind-textures pass) - (render pass (or (shader-program pass) - (error "Shader program was never allocated!!")))) - -(defmethod render ((pass compute-pass) (program shader-program)) - (let ((work-groups (work-groups pass)) - (barrier (slot-value pass 'barrier))) - (etypecase work-groups - (vec3 - (%gl:dispatch-compute - (truncate (vx work-groups)) - (truncate (vy work-groups)) - (truncate (vz work-groups)))) - (integer - (%gl:dispatch-compute-indirect work-groups)) - (buffer-object - (%gl:bind-buffer :dispatch-indirect-buffer (gl-name work-groups)) - (%gl:dispatch-compute-indirect 0))) - (when (/= 0 barrier) - (%gl:memory-barrier barrier)))) +(defmethod render :before ((pass compute-pass) (_ null)) + (bind-textures pass)) (defmethod render ((pass compute-pass) (work-groups vec3)) (setf (work-groups pass) work-groups) diff --git a/skybox.lisp b/skybox.lisp index 4ba5d0aa1..bd3248705 100644 --- a/skybox.lisp +++ b/skybox.lisp @@ -16,16 +16,11 @@ (stage (vertex-array skybox) area)) (defmethod render ((skybox skybox) (shader shader-program)) - (let ((texture (texture skybox))) - (setf (uniform shader "view_matrix") (view-matrix)) - (setf (uniform shader "projection_matrix") (projection-matrix)) - (gl:depth-mask NIL) - (gl:active-texture :texture0) - (gl:bind-vertex-array (gl-name (vertex-array skybox))) - (gl:bind-texture (target texture) (gl-name texture)) - (gl:draw-arrays :triangle-strip 0 4) - (gl:bind-texture (target texture) 0) - (gl:depth-mask T))) + (setf (uniform shader "view_matrix") (view-matrix)) + (setf (uniform shader "projection_matrix") (projection-matrix)) + (with-render-settings (:no-depth-writes) + (bind (texture skybox) NIL) + (render (vertex-array skybox) NIL))) (define-class-shader (skybox :vertex-shader) "const vec2 quad_vertices[4] = vec2[4](vec2(-1.0, -1.0), vec2(1.0, -1.0), vec2(-1.0, 1.0), vec2(1.0, 1.0)); diff --git a/sprite.lisp b/sprite.lisp index e408f2309..16743a1f2 100644 --- a/sprite.lisp +++ b/sprite.lisp @@ -58,10 +58,8 @@ (setf (uniform program "model_matrix") (model-matrix)) (setf (uniform program "view_matrix") (view-matrix)) (setf (uniform program "projection_matrix") (projection-matrix)) - (let ((vao (vertex-array entity))) - (gl:bind-vertex-array (gl-name vao)) - (%gl:draw-arrays :triangle-strip (* 4 (the (unsigned-byte 32) (frame-idx entity))) 4) - (gl:bind-vertex-array 0))) + (setf (size (vertex-array entity)) 4) + (render (vertex-array entity) (* 4 (the (unsigned-byte 32) (frame-idx entity))))) (define-shader-entity animated-sprite (listener sprite-entity) ((clock :initform 0f0 :accessor clock) diff --git a/tile-layer.lisp b/tile-layer.lisp index c4ddf07f5..33ce14d6f 100644 --- a/tile-layer.lisp +++ b/tile-layer.lisp @@ -60,7 +60,7 @@ (defmethod (setf pixel-data) ((data vector) (layer tile-layer)) (replace (pixel-data (tilemap layer)) data) - (%update-tile-layer layer)) + (update-buffer-data (tilemap layer) T)) (defmethod resize ((layer tile-layer) w h) (let ((size (vec2 (floor w (vx (tile-size layer))) (floor h (vy (tile-size layer)))))) @@ -110,13 +110,8 @@ (let ((idx (* 2 (+ x (* y (truncate (vx (size layer)))))))) (setf (aref dat (+ 0 idx)) (car value)) (setf (aref dat (+ 1 idx)) (cdr value)))) - (%update-tile-layer layer) - #++ ;; TODO: Optimize - (sb-sys:with-pinned-objects (dat) - (gl:bind-texture :texture-2d (gl-name texture)) - (%gl:tex-sub-image-2d :texture-2d 0 x y 1 1 (pixel-format texture) (pixel-type texture) - (cffi:inc-pointer (sb-sys:vector-sap dat) pos)) - (gl:bind-texture :texture-2d 0))) + ;; TODO: Optimize + (update-buffer-data (tilemap layer) T)) value) (defmethod tile ((location vec3) (layer tile-layer)) @@ -125,23 +120,11 @@ (defmethod (setf tile) (value (location vec3) (layer tile-layer)) (setf (tile (vxy location) layer) value)) -(defun %update-tile-layer (layer) - (let ((dat (pixel-data layer))) - (sb-sys:with-pinned-objects (dat) - (let ((texture (tilemap layer)) - (width (truncate (vx (size layer)))) - (height (truncate (vy (size layer))))) - (gl:bind-texture :texture-2d (gl-name texture)) - (%gl:tex-sub-image-2d :texture-2d 0 0 0 width height - (pixel-format texture) (pixel-type texture) - (sb-sys:vector-sap dat)) - (gl:bind-texture :texture-2d 0))))) - (defmethod clear ((layer tile-layer)) (let ((dat (pixel-data layer))) (dotimes (i (truncate (* 2 (vx (size layer)) (vy (size layer))))) (setf (aref dat i) 0)) - (%update-tile-layer layer))) + (update-buffer-data (tilemap layer) T))) (defmethod render ((layer tile-layer) (program shader-program)) (when (< 0.0 (visibility layer)) @@ -153,10 +136,8 @@ (setf (uniform program "model_matrix") *model-matrix*) (setf (uniform program "tilemap") 0) (setf (uniform program "tileset") 1) - (gl:active-texture :texture0) - (gl:bind-texture :texture-2d (gl-name (tilemap layer))) - (gl:active-texture :texture1) - (gl:bind-texture :texture-2d (gl-name (tileset layer))) + (bind (tilemap layer) 0) + (bind (tileset layer) 1) (render (vertex-array layer) program))) (define-class-shader (tile-layer :vertex-shader) diff --git a/toolkit.lisp b/toolkit.lisp index c5567fc48..733ca5d12 100644 --- a/toolkit.lisp +++ b/toolkit.lisp @@ -77,11 +77,6 @@ (defun round-to (base number) (* base (ceiling number base))) -(defun gl-property (name) - (handler-case (gl:get* name) - (error (err) (declare (ignore err)) - :unavailable))) - (defmethod apply-class-changes ((class standard-class))) (defmethod apply-class-changes :before ((class standard-class)) @@ -816,14 +811,6 @@ (write-char (char-upcase c) out))))) package)) -(defun gl-vendor () - (let ((vendor (gl:get-string :vendor))) - (cond ((search "Intel" vendor) :intel) - ((search "NVIDIA" vendor) :nvidia) - ((search "ATI" vendor) :amd) - ((search "AMD" vendor) :amd) - (T :unknown)))) - (defun check-texture-size (width height) (let ((max (gl:get* :max-texture-size))) (when (< max (max width height)) @@ -1137,36 +1124,6 @@ (single-float :float) (double-flot :double))))) -(define-global +gl-extensions+ ()) - -(defun cache-gl-extensions () - (let ((*package* (find-package "KEYWORD"))) - (setf +gl-extensions+ - (loop for i from 0 below (gl:get* :num-extensions) - for name = (ignore-errors (gl:get-string-i :extensions i)) - when name - collect (cffi:translate-name-from-foreign name *package*))))) - -(defun gl-extension-p (extension) - (find extension +gl-extensions+)) - -(defmacro when-gl-extension (extension &body body) - (let ((list (enlist extension))) - ;; TODO: Optimise this by caching the test after first runtime. - `(when (and ,@(loop for extension in list - collect `(find ,extension +gl-extensions+))) - ,@body))) - -(defmacro gl-extension-case (&body cases) - `(cond ,@(loop for (extensions . body) in cases - collect (case extensions - ((T otherwise) - `(T ,@body)) - (T - `((and ,@(loop for extension in (enlist extensions) - collect `(find ,extension +gl-extensions+))) - ,@body)))))) - (declaim (inline dbg)) #-trial-release (defun dbg (&rest parts)