// // The multimedia graphics platform GLScene https://github.com/glscene // unit GLS.Context; (* Prototypes and base implementation of TGLContext *) interface {$I GLScene.inc} uses Winapi.OpenGL, Winapi.OpenGLext, Winapi.Windows, System.Classes, System.SysUtils, System.Types, System.SyncObjs, VCL.Forms, VCL.Controls, VCL.Consts, {$IFDEF USE_SERVICE_CONTEXT} GLS.Generics, {$ENDIF} GLS.OpenGLTokens, GLS.OpenGLAdapter, GLS.XOpenGL, GLS.VectorGeometry, GLS.Strings, GLS.VectorTypes, GLS.State, GLS.PipelineTransformation, GLS.TextureFormat, GLS.Logger; // Buffer ID's for Multiple-Render-Targets (using GL_ATI_draw_buffers) const MRT_BUFFERS: array [0 .. 3] of TGLuint = (GL_FRONT_LEFT, GL_AUX0, GL_AUX1, GL_AUX2); type TGLRCOption = (rcoDoubleBuffered, rcoStereo, rcoDebug, rcoOGL_ES); TGLRCOptions = set of TGLRCOption; TGLContextLayer = (clUnderlay2, clUnderlay1, clMainPlane, clOverlay1, clOverlay2); TFinishTaskEvent = class(TEvent) public constructor Create; reintroduce; end; TTaskProcedure = procedure of object; stdcall; TServiceContextTask = record Task: TTaskProcedure; Event: TFinishTaskEvent; end; {$IFDEF USE_SERVICE_CONTEXT} TServiceContextTaskList = {$IFDEF USE_GENERIC_PREFIX} specialize {$ENDIF} GThreadList; {$ENDIF USE_SERVICE_CONTEXT} TGLContextManager = class; TGLContextAcceleration = (chaUnknown, chaHardware, chaSoftware); TGLAntiAliasing = ( // Multisample Antialiasing aaDefault, aaNone, aa2x, aa2xHQ, aa4x, aa4xHQ, aa6x, aa8x, aa16x, // Coverage Sampling Antialiasing csa8x, csa8xHQ, csa16x, csa16xHQ); TGLVSyncMode = (vsmSync, vsmNoSync); (* Wrapper around an OpenGL rendering context. The aim of this class is to offer platform-independant initialization, activation and management of OpenGL rendering context. The class also offers notifications event and error/problems detection. This is a virtual abstract a class, and platform-specific subclasses must be used. All rendering context share the same lists *) TGLContext = class private FColorBits, FAlphaBits: Integer; FDepthBits: Integer; FStencilBits: Integer; FAccumBits: Integer; FAuxBuffers: Integer; FAntiAliasing: TGLAntiAliasing; FOptions: TGLRCOptions; FOnDestroyContext: TNotifyEvent; FManager: TGLContextManager; FActivationCount: Integer; FOwnedHandlesCount: Integer; FIsPraparationNeed: Boolean; procedure SetColorBits(const aColorBits: Integer); inline; procedure SetAlphaBits(const aAlphaBits: Integer); inline; procedure SetDepthBits(const val: Integer); inline; procedure SetStencilBits(const aStencilBits: Integer); inline; procedure SetAccumBits(const aAccumBits: Integer); inline; procedure SetAuxBuffers(const aAuxBuffers: Integer); inline; procedure SetOptions(const aOptions: TGLRCOptions); inline; procedure SetAntiAliasing(const val: TGLAntiAliasing); inline; procedure SetAcceleration(const val: TGLContextAcceleration); inline; function GetActive: Boolean; inline; procedure SetActive(const aActive: Boolean); inline; procedure SetLayer(const Value: TGLContextLayer); inline; protected Fgl: TGLExtensionsAndEntryPoints; Fxgl: TGLMultitextureCoordinator; FGLStates: TGLStateCache; FTransformation: TGLTransformation; FAcceleration: TGLContextAcceleration; FLayer: TGLContextLayer; {$IFNDEF USE_MULTITHREAD} FSharedContexts: TList; {$ELSE} FSharedContexts: TThreadList; FLock: TCriticalSection; {$ENDIF} procedure PropagateSharedContext; procedure DoCreateContext(ADeviceHandle: HDC); virtual; abstract; procedure DoCreateMemoryContext(outputDevice: HWND; width, height: Integer; BufferCount: Integer = 1); virtual; abstract; function DoShareLists(aContext: TGLContext): Boolean; virtual; abstract; procedure DoDestroyContext; virtual; abstract; procedure DoActivate; virtual; abstract; procedure DoDeactivate; virtual; abstract; class function ServiceContext: TGLContext; procedure MakeGLCurrent; public constructor Create; virtual; destructor Destroy; override; // An application-side cache of global per-context OpenGL states and parameters property GLStates: TGLStateCache read FGLStates; property PipelineTransformation: TGLTransformation read FTransformation; // Context manager reference property Manager: TGLContextManager read FManager; // Color bits for the rendering context property ColorBits: Integer read FColorBits write SetColorBits; // Alpha bits for the rendering context property AlphaBits: Integer read FAlphaBits write SetAlphaBits; // Depth bits for the rendering context property DepthBits: Integer read FDepthBits write SetDepthBits; // Stencil bits for the rendering context property StencilBits: Integer read FStencilBits write SetStencilBits; // Accumulation buffer bits for the rendering context property AccumBits: Integer read FAccumBits write SetAccumBits; // Auxiliary buffers bits for the rendering context property AuxBuffers: Integer read FAuxBuffers write SetAuxBuffers; // AntiAliasing option. Ignored if not hardware supported, currently based on ARB_multisample property AntiAliasing: TGLAntiAliasing read FAntiAliasing write SetAntiAliasing; // Specifies the layer plane that the rendering context is bound to property Layer: TGLContextLayer read FLayer write SetLayer; // Rendering context options property Options: TGLRCOptions read FOptions write SetOptions; (* Allows reading and defining the activity for the context. The methods of this property are just wrappers around calls to Activate and Deactivate *) property Active: Boolean read GetActive write SetActive; // Indicates if the context is hardware-accelerated property Acceleration: TGLContextAcceleration read FAcceleration write SetAcceleration; (* Triggered whenever the context is destroyed. This events happens *before* the context has been actually destroyed, OpenGL resource cleanup can still occur here *) property OnDestroyContext: TNotifyEvent read FOnDestroyContext write FOnDestroyContext; // Creates the context. This method must be invoked before the context can be used procedure CreateContext(ADeviceHandle: HDC); overload; (* Creates an in-memory context. The function should fail if no hardware-accelerated memory context can be created (the CreateContext method can handle software OpenGL contexts) *) procedure CreateMemoryContext(outputDevice: HWND; width, height: Integer; BufferCount: Integer = 1); (* Setup display list sharing between two rendering contexts. Both contexts must have the same pixel format *) procedure ShareLists(aContext: TGLContext); (* Destroy the context. Will fail if no context has been created. The method will first invoke the OnDestroyContext event, then attempts to deactivate the context (if it is active) before destroying it *) procedure DestroyContext; (* Activates the context. A context can be activated multiple times (and must be deactivated the same number of times), but this function will fail if another context is already active. *) procedure Activate; (* Deactivates the context. Will fail if the context is not active or another context has been activated *) procedure Deactivate; // Call OnPrepare for all handles procedure PrepareHandlesData; (* Returns true if the context is valid. A context is valid from the time it has been successfully created to the time of its destruction. *) function IsValid: Boolean; virtual; abstract; // Request to swap front and back buffers if they were defined procedure SwapBuffers; virtual; abstract; // Returns the first compatible context that isn't self in the shares function FindCompatibleContext: TGLContext; procedure DestroyAllHandles; function RenderOutputDevice: Pointer; virtual; abstract; // Access to OpenGL command and extension property GL: TGLExtensionsAndEntryPoints read Fgl; property MultitextureCoordinator: TGLMultitextureCoordinator read Fxgl; property IsPraparationNeed: Boolean read FIsPraparationNeed; end; TGLContextClass = class of TGLContext; (* A TGLContext with screen control property and methods. This variety of contexts is for drivers that access windows and OpenGL through an intermediate opaque cross-platform API. TGLSceneViewer won't use them, TGLMemoryViewer may be able to use them, but most of the time they will be accessed through a specific viewer class/subclass *) TGLScreenControlingContext = class(TGLContext) strict private FWidth, FHeight: Integer; FFullScreen: Boolean; public property Width: Integer read FWidth write FWidth; property Height: Integer read FHeight write FHeight; property FullScreen: Boolean read FFullScreen write FFullScreen; end; PGLRCHandle = ^TGLRCHandle; TGLRCHandle = record FRenderingContext: TGLContext; FHandle: TGLuint; FChanged: Boolean; end; TOnPrepareHandleData = procedure(aContext: TGLContext) of object; (* Wrapper around an OpenGL context handle. This wrapper also takes care of context registrations and data releases related to context releases an cleanups. This is an abstract class, use the TGLListHandle and TGLTextureHandle subclasses *) TGLContextHandle = class private FHandles: TList; FLastHandle: PGLRCHandle; FOnPrepare: TOnPrepareHandleData; function GetHandle: TGLuint; inline; function GetContext: TGLContext; function SearchRC(aContext: TGLContext): PGLRCHandle; function RCItem(AIndex: Integer): PGLRCHandle; inline; procedure CheckCurrentRC; protected // Invoked by when there is no compatible context left for relocation procedure ContextDestroying; // Specifies if the handle can be transfered across shared contexts class function Transferable: Boolean; virtual; class function IsValid(const ID: TGLuint): Boolean; virtual; function DoAllocateHandle: TGLuint; virtual; abstract; procedure DoDestroyHandle(var AHandle: TGLuint); virtual; abstract; public constructor Create; virtual; constructor CreateAndAllocate(failIfAllocationFailed: Boolean = True); destructor Destroy; override; // Return OpenGL identifier in current context property Handle: TGLuint read GetHandle; (* Return current rendering context if handle is allocated in it or first context where handle is allocated. *) property RenderingContext: TGLContext read GetContext; // Return True is data need update in current context function IsDataNeedUpdate: Boolean; inline; // Return True if data updated in all contexts function IsDataComplitelyUpdated: Boolean; // Notify the data was updated in current context procedure NotifyDataUpdated; // Notify the data was changed through all context procedure NotifyChangesOfData; // Checks if required extensions / OpenGL version are met class function IsSupported: Boolean; virtual; function IsAllocatedForContext(aContext: TGLContext = nil): Boolean; function IsShared: Boolean; function AllocateHandle: TGLuint; procedure DestroyHandle; property OnPrapare: TOnPrepareHandleData read FOnPrepare write FOnPrepare; end; TGLVirtualHandle = class; TGLVirtualHandleEvent = procedure(Sender: TGLVirtualHandle; var Handle: TGLuint) of object; // A context handle with event-based handle allocation and destruction TGLVirtualHandle = class(TGLContextHandle) private FOnAllocate, FOnDestroy: TGLVirtualHandleEvent; FTag: Integer; protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function Transferable: Boolean; override; public property OnAllocate: TGLVirtualHandleEvent read FOnAllocate write FOnAllocate; property OnDestroy: TGLVirtualHandleEvent read FOnDestroy write FOnDestroy; property Tag: Integer read FTag write FTag; end; // Transferable virtual handle TGLVirtualHandleTransf = class(TGLVirtualHandle) protected class function Transferable: Boolean; override; end; // Manages a handle to a display list TGLListHandle = class(TGLContextHandle) protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public procedure NewList(mode: TGLuint); inline; procedure EndList; inline; procedure CallList; inline; end; // Manages a handle to a texture TGLTextureHandle = class(TGLContextHandle) private FTarget: TGLTextureTarget; procedure SetTarget(ATarget: TGLTextureTarget); protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public property Target: TGLTextureTarget read FTarget write SetTarget; end; // Manages a handle to a sampler TGLSamplerHandle = class(TGLContextHandle) protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public class function IsSupported: Boolean; override; end; (* Manages a handle to a query. Do not use this class directly, use one of its subclasses instead. *) TGLQueryHandle = class(TGLContextHandle) private FActive: Boolean; protected class function Transferable: Boolean; override; function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; function GetTarget: TGLuint; virtual; abstract; function GetQueryType: TGLQueryType; virtual; abstract; class function IsValid(const ID: TGLuint): Boolean; override; public procedure BeginQuery; procedure EndQuery; // Check if result is available from the query. Result may not be available // immediately after ending the query function IsResultAvailable: Boolean; // Number of bits used to store the query result. eg. 32/64 bit function CounterBits: Integer; // Retrieve query result, may cause a stall if the result is not available yet function QueryResultInt: TGLint; function QueryResultUInt: TGLUInt; function QueryResultInt64: TGLint64EXT; function QueryResultUInt64: TGLuint64EXT; function QueryResultBool: TGLboolean; property Target: TGLuint read GetTarget; property QueryType: TGLQueryType read GetQueryType; // True if within a Begin/EndQuery. property Active: Boolean read FActive; end; (* Manages a handle to an occlusion query. Requires OpenGL 1.5+ Does *NOT* check for extension availability, this is assumed to have been checked by the user. *) TGLOcclusionQueryHandle = class(TGLQueryHandle) protected function GetTarget: TGLuint; override; function GetQueryType: TGLQueryType; override; public class function IsSupported: Boolean; override; // Number of samples (pixels) drawn during the query, some pixels may // be drawn to several times in the same query function PixelCount: Integer; end; TGLBooleanOcclusionQueryHandle = class(TGLQueryHandle) protected function GetTarget: TGLuint; override; function GetQueryType: TGLQueryType; override; public class function IsSupported: Boolean; override; end; (* Manages a handle to a timer query. Requires GL_EXT_timer_query extension. Does *NOT* check for extension availability, this is assumed to have been checked by the user. *) TGLTimerQueryHandle = class(TGLQueryHandle) protected function GetTarget: TGLuint; override; function GetQueryType: TGLQueryType; override; public class function IsSupported: Boolean; override; // Time, in nanoseconds (1 ns = 10^-9 s) between starting + ending the query. // with 32 bit integer can measure up to approximately 4 seconds, use // QueryResultUInt64 if you may need longer function Time: Integer; end; (* Manages a handle to a primitive query. Requires OpenGL 3.0+ Does *NOT* check for extension availability, this is assumed to have been checked by the user. *) TGLPrimitiveQueryHandle = class(TGLQueryHandle) protected function GetTarget: TGLuint; override; function GetQueryType: TGLQueryType; override; public class function IsSupported: Boolean; override; // Number of primitives (eg. Points, Triangles etc.) drawn whilst the // query was active function PrimitivesGenerated: Integer; end; (* Manages a handle to a Buffer Object. Does *NOT* check for extension availability, this is assumed to have been checked by the user. *) TGLBufferObjectHandle = class(TGLContextHandle) private FSize: Integer; protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; function GetTarget: TGLuint; virtual; abstract; class function IsValid(const ID: TGLuint): Boolean; override; public // Creates the buffer object buffer and initializes it. constructor CreateFromData(p: Pointer; size: Integer; bufferUsage: TGLuint); procedure Bind; virtual; abstract; // Note that it is not necessary to UnBind before Binding another buffer. procedure UnBind; virtual; abstract; (* Bind a buffer object to an indexed target, used by transform feedback buffer objects and uniform buffer objects. (OpenGL 3.0+) *) procedure BindRange(index: TGLuint; offset: TGLintptr; size: TGLsizeiptr); virtual; // Equivalent to calling BindRange with offset = 0, and size = the size of buffer. procedure BindBase(index: TGLuint); virtual; procedure UnBindBase(index: TGLuint); virtual; (* Specifies buffer content. Common bufferUsage values are GL_STATIC_DRAW_ARB for data that will change rarely, but be used often, GL_STREAM_DRAW_ARB for data specified once but used only a few times, and GL_DYNAMIC_DRAW_ARB for data that is re-specified very often. Valid only if the buffer has been bound. *) procedure BufferData(p: Pointer; size: Integer; bufferUsage: TGLuint); // Invokes Bind then BufferData procedure BindBufferData(p: Pointer; size: Integer; bufferUsage: TGLuint); (* Updates part of an already existing buffer. offset and size indicate which part of the data in the buffer is to bo modified and p where the data should be taken from. *) procedure BufferSubData(offset, size: Integer; p: Pointer); (* Map buffer content to memory. Values for access are GL_READ_ONLY_ARB, GL_WRITE_ONLY_ARB and GL_READ_WRITE_ARB. Valid only if the buffer has been bound, must be followed by an UnmapBuffer, only one buffer may be mapped at a time. *) function MapBuffer(access: TGLuint): Pointer; function MapBufferRange(offset: TGLint; len: TGLsizei; access: TGLbitfield): Pointer; procedure Flush(offset: TGLint; len: TGLsizei); (* Unmap buffer content from memory. Must follow a MapBuffer, and happen before the buffer is unbound. *) function UnmapBuffer: Boolean; class function IsSupported: Boolean; override; property Target: TGLuint read GetTarget; property BufferSize: Integer read FSize; end; (* Manages a handle to an Vertex Buffer Object, VBO. Does *NOT* check for extension availability, this is assumed to have been checked by the user. Do not use this class directly, use one of its subclasses instead. *) TGLVBOHandle = class(TGLBufferObjectHandle) private function GetVBOTarget: TGLuint; public property VBOTarget: TGLuint read GetVBOTarget; end; // Manages a handle to VBO Array Buffer. Typically used to store vertices, normals, texcoords, etc. TGLVBOArrayBufferHandle = class(TGLVBOHandle) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; end; // Manages a handle to VBO Element Array Buffer. Typically used to store vertex indices. TGLVBOElementArrayHandle = class(TGLVBOHandle) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; end; (* Manages a handle to PBO Pixel Pack Buffer. When bound, commands such as ReadPixels write their data into a buffer object. *) TGLPackPBOHandle = class(TGLBufferObjectHandle) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; class function IsSupported: Boolean; override; end; (* Manages a handle to PBO Pixel Unpack Buffer. When bound, commands such as DrawPixels read their data from a buffer object *) TGLUnpackPBOHandle = class(TGLBufferObjectHandle) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; class function IsSupported: Boolean; override; end; (* Manages a handle to a Transform Feedback Buffer Object. Transform feedback buffers can be used to capture vertex data from the vertex or geometry shader stage to perform further processing without going on to the fragment shader stage. *) TGLTransformFeedbackBufferHandle = class(TGLBufferObjectHandle) // FTransformFeedbackBufferBuffer: array[0..15] of Cardinal; // (0, 0, 0, ...) // FTransformFeedbackBufferStart: array[0..15] of TGLuint64; // (0, 0, 0, ...) // FTransformFeedbackBufferSize: array[0..15] of TGLuint64; // (0, 0, 0, ...) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; procedure BeginTransformFeedback(primitiveMode: TGLuint); procedure EndTransformFeedback(); procedure BindRange(index: TGLuint; offset: TGLintptr; size: TGLsizeiptr); override; procedure BindBase(index: TGLuint); override; procedure UnBindBase(index: TGLuint); override; class function IsSupported: Boolean; override; end; // Manages a handle to a Buffer Texture. (TBO) TGLTextureBufferHandle = class(TGLBufferObjectHandle) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; class function IsSupported: Boolean; override; end; (* Manages a handle to a Uniform Buffer Object (UBO). Uniform buffer objects store "uniform blocks"; groups of uniforms that can be passed as a group into a GLSL program *) TGLUniformBufferHandle = class(TGLBufferObjectHandle) /// FUniformBufferBuffer: array[0..15] of GLuint; // (0, 0, 0, ...) /// FUniformBufferStart: array[0..15] of TGLuint64; // (0, 0, 0, ...) /// FUniformBufferSize: array[0..15] of TGLuint64; // (0, 0, 0, ...) protected function GetTarget: TGLuint; override; public procedure Bind; override; procedure UnBind; override; procedure BindRange(index: TGLuint; offset: TGLintptr; size: TGLsizeiptr); override; procedure BindBase(index: TGLuint); override; procedure UnBindBase(index: TGLuint); override; class function IsSupported: Boolean; override; end; (* Manages a handle to a Vertex Array Object (VAO). Vertex array objects are used to rapidly switch between large sets of array state *) TGLVertexArrayHandle = class(TGLContextHandle) protected class function Transferable: Boolean; override; function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public procedure Bind; procedure UnBind; class function IsSupported: Boolean; override; end; TGLFramebufferStatus = (fsComplete, fsIncompleteAttachment, fsIncompleteMissingAttachment, fsIncompleteDuplicateAttachment, fsIncompleteDimensions, fsIncompleteFormats, fsIncompleteDrawBuffer, fsIncompleteReadBuffer, fsUnsupported, fsIncompleteMultisample, fsStatusError); (* Manages a handle to a Framebuffer Object (FBO). Framebuffer objects provide a way of drawing to rendering destinations other than the buffers provided to the GL by the window-system. One or more "framebuffer-attachable images" can be attached to a Framebuffer for uses such as: offscreen rendering, "render to texture" + "multiple render targets" (MRT). There are several types of framebuffer-attachable images: - The image of a renderbuffer object, which is always 2D. - A single level of a 1D texture, which is treated as a 2D image with a height of one. - A single level of a 2D or rectangle texture. - A single face of a cube map texture level, which is treated as a 2D image. - A single layer of a 1D or 2D array texture or 3D texture, which is treated as a 2D image. Additionally, an entire level of a 3D texture, cube map texture, or 1D or 2D array texture can be attached to an attachment point. Such attachments are treated as an array of 2D images, arranged in layers, and the corresponding attachment point is considered to be layered *) TGLFramebufferHandle = class(TGLContextHandle) protected class function Transferable: Boolean; override; function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public // Bind framebuffer for both drawing + reading procedure Bind; // Bind framebuffer for drawing procedure BindForDrawing; // Bind framebuffer for reading procedure BindForReading; { Note that it is not necessary to unbind before binding another framebuffer. } procedure UnBind; procedure UnBindForDrawing; procedure UnBindForReading; // target = GL_DRAW_FRAMEBUFFER, GL_READ_FRAMEBUFFER, GL_FRAMEBUFFER (attach to both READ + DRAW) // attachment = COLOR_ATTACHMENTi, DEPTH_ATTACHMENT, STENCIL_ATTACHMENT, DEPTH_STENCIL_ATTACHMENT procedure Attach1DTexture(Target: TGLuint; attachment: TGLuint; textarget: TGLuint; texture: TGLuint; level: TGLint); procedure Attach2DTexture(Target: TGLuint; attachment: TGLuint; textarget: TGLuint; texture: TGLuint; level: TGLint); procedure Attach3DTexture(Target: TGLuint; attachment: TGLuint; textarget: TGLuint; texture: TGLuint; level: TGLint; Layer: TGLint); procedure AttachLayer(Target: TGLuint; attachment: TGLuint; texture: TGLuint; level: TGLint; Layer: TGLint); procedure AttachRenderBuffer(Target: TGLuint; attachment: TGLuint; renderbuffertarget: TGLuint; renderbuffer: TGLuint); (* OpenGL 3.2+ only. If texture is the name of a three-dimensional texture, cube map texture, one-or two-dimensional array texture, or two-dimensional multisample array texture, the texture level attached to the framebuffer attachment point is an array of images, and the framebuffer attachment is considered layered *) procedure AttachTexture(Target: TGLuint; attachment: TGLuint; texture: TGLuint; level: TGLint); // OpenGL 3.2+ only procedure AttachTextureLayer(Target: TGLuint; attachment: TGLuint; texture: TGLuint; level: TGLint; Layer: TGLint); // copy rect from bound read framebuffer to bound draw framebuffer procedure Blit(srcX0: TGLint; srcY0: TGLint; srcX1: TGLint; srcY1: TGLint; dstX0: TGLint; dstY0: TGLint; dstX1: TGLint; dstY1: TGLint; mask: TGLbitfield; filter: TGLuint); (* target = GL_DRAW_FRAMEBUFFER, GL_READ_FRAMEBUFFER, GL_FRAMEBUFFER (equivalent to GL_DRAW_FRAMEBUFFER) If default framebuffer (0) is bound: attachment = GL_FRONT_LEFT, GL_FRONT_RIGHT, GL_BACK_LEFT, or GL_BACK_RIGHT, GL_DEPTH, GL_STENCIL if a framebuffer object is bound: attachment = GL_COLOR_ATTACHMENTi, GL_DEPTH_ATTACHMENT, GL_STENCIL_ATTACHMENT, GL_DEPTH_STENCIL_ATTACHMENT param = GL_FRAMEBUFFER_ATTACHMENT_(OBJECT_TYPE, OBJECT_NAME, RED_SIZE, GREEN_SIZE, BLUE_SIZE, ALPHA_SIZE, DEPTH_SIZE, STENCIL_SIZE, COMPONENT_TYPE, COLOR_ENCODING, TEXTURE_LEVEL, LAYERED, TEXTURE_CUBE_MAP_FACE, TEXTURE_LAYER *) function GetAttachmentParameter(Target: TGLuint; attachment: TGLuint; pname: TGLuint): TGLint; (* Returns the type of object bound to attachment point: GL_NONE, GL_FRAMEBUFFER_DEFAULT, GL_TEXTURE, or GL_RENDERBUFFER *) function GetAttachmentObjectType(Target: TGLuint; attachment: TGLuint): TGLint; // Returns the name (ID) of the texture or renderbuffer attached to attachment point function GetAttachmentObjectName(Target: TGLuint; attachment: TGLuint): TGLint; function GetStatus: TGLFramebufferStatus; function GetStringStatus(out clarification: string): TGLFramebufferStatus; class function IsSupported: Boolean; override; end; (* Manages a handle to a Renderbuffer Object. A Renderbuffer is a "framebuffer-attachable image" for generalized offscreen rendering and it also provides a means to support rendering to GL logical buffer types which have no corresponding texture format (stencil, accum, etc). *) TGLRenderbufferHandle = class(TGLContextHandle) protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; public procedure Bind; procedure UnBind; procedure SetStorage(internalformat: TGLuint; width, height: TGLsizei); procedure SetStorageMultisample(internalformat: TGLuint; samples: TGLsizei; width, height: TGLsizei); class function IsSupported: Boolean; override; end; TGLARBProgramHandle = class(TGLContextHandle) private FReady: Boolean; FInfoLog: string; protected function DoAllocateHandle: TGLuint; override; procedure DoDestroyHandle(var AHandle: TGLuint); override; class function IsValid(const ID: TGLuint): Boolean; override; class function GetTarget: TGLuint; virtual; abstract; public procedure LoadARBProgram(const AText: string); procedure Enable; procedure Disable; procedure Bind; property Ready: Boolean read FReady; property InfoLog: string read FInfoLog; end; TGLARBVertexProgramHandle = class(TGLARBProgramHandle) protected class function GetTarget: TGLuint; override; public class function IsSupported: Boolean; override; end; TGLARBFragmentProgramHandle = class(TGLARBProgramHandle) protected class function GetTarget: TGLuint; override; public class function IsSupported: Boolean; override; end; TGLARBGeometryProgramHandle = class(TGLARBProgramHandle) protected class function GetTarget: TGLuint; override; public class function IsSupported: Boolean; override; end; (* Base class for GLSL handles (programs and shaders). Do not use this class directly, use one of its subclasses instead *) TGLSLHandle = class(TGLContextHandle) protected procedure DoDestroyHandle(var AHandle: TGLuint); override; public function InfoLog: string; class function IsSupported: Boolean; override; end; (* Manages a handle to a Shader Object. Does *NOT* check for extension availability, this is assumed to have been checked by the user. Do not use this class directly, use one of its subclasses instead *) TGLShaderHandle = class(TGLSLHandle) private FShaderType: TGLuint; protected function DoAllocateHandle: TGLuint; override; class function IsValid(const ID: TGLuint): Boolean; override; public procedure ShaderSource(const source: AnsiString); overload; // Returns True if compilation sucessful function CompileShader: Boolean; property ShaderType: TGLuint read FShaderType; end; TGLShaderHandleClass = class of TGLShaderHandle; // Manages a handle to a Vertex Shader Object TGLVertexShaderHandle = class(TGLShaderHandle) public constructor Create; override; class function IsSupported: Boolean; override; end; // Manages a handle to a Geometry Shader Object TGLGeometryShaderHandle = class(TGLShaderHandle) public constructor Create; override; class function IsSupported: Boolean; override; end; // Manages a handle to a Fragment Shader Object TGLFragmentShaderHandle = class(TGLShaderHandle) public constructor Create; override; class function IsSupported: Boolean; override; end; // Manages a handle to a Tessellation Control Shader Object TGLTessControlShaderHandle = class(TGLShaderHandle) public constructor Create; override; class function IsSupported: Boolean; override; end; // Manages a handle to a Tessellation Evaluation Shader Object TGLTessEvaluationShaderHandle = class(TGLShaderHandle) public constructor Create; override; class function IsSupported: Boolean; override; end; (* Manages a GLSL Program Object. Does *NOT* check for extension availability, this is assumed to have been checked by the user *) TGLProgramHandle = class(TGLSLHandle) public class function IsValid(const ID: TGLuint): Boolean; override; private FName: string; function GetUniform1i(const index: string): Integer; procedure SetUniform1i(const index: string; val: Integer); function GetUniform2i(const index: string): TVector2i; procedure SetUniform2i(const index: string; const Value: TVector2i); function GetUniform3i(const index: string): TVector3i; procedure SetUniform3i(const index: string; const Value: TVector3i); function GetUniform4i(const index: string): TVector4i; procedure SetUniform4i(const index: string; const Value: TVector4i); function GetUniform1f(const index: string): Single; procedure SetUniform1f(const index: string; val: Single); function GetUniform2f(const index: string): TVector2f; procedure SetUniform2f(const index: string; const val: TVector2f); function GetUniform3f(const index: string): TAffineVector; procedure SetUniform3f(const index: string; const val: TAffineVector); function GetUniform4f(const index: string): TGLVector; procedure SetUniform4f(const index: string; const val: TGLVector); function GetUniformMatrix2fv(const index: string): TMatrix2f; procedure SetUniformMatrix2fv(const index: string; const val: TMatrix2f); function GetUniformMatrix3fv(const index: string): TMatrix3f; procedure SetUniformMatrix3fv(const index: string; const val: TMatrix3f); function GetUniformMatrix4fv(const index: string): TGLMatrix; procedure SetUniformMatrix4fv(const index: string; const val: TGLMatrix); function GetUniformTextureHandle(const Index: string; const TextureIndex: Integer; const TextureTarget: TGLTextureTarget) : TGLuint; procedure SetUniformTextureHandle(const Index: string; const TextureIndex: Integer; const TextureTarget: TGLTextureTarget; const Value: TGLuint); procedure SetUniformBuffer(const Index: string; Value: TGLUniformBufferHandle); protected function DoAllocateHandle: TGLuint; override; public property Name: string read FName write FName; constructor Create; override; (* Compile and attach a new shader. Raises an EGLShader exception in case of failure. *) procedure AddShader(ShaderType: TGLShaderHandleClass; const ShaderSource: string; treatWarningsAsErrors: Boolean = False); procedure AttachObject(shader: TGLShaderHandle); procedure DetachAllObject; procedure BindAttribLocation(index: Integer; const aName: string); procedure BindFragDataLocation(index: Integer; const aName: string); function LinkProgram: Boolean; function ValidateProgram: Boolean; function GetAttribLocation(const aName: string): Integer; function GetUniformLocation(const aName: string): Integer; function GetUniformOffset(const aName: string): PGLInt; function GetUniformBlockIndex(const aName: string): Integer; function GetVaryingLocation(const aName: string): Integer; // Currently, NVidia-specific. procedure AddActiveVarying(const aName: string); // Currently, NVidia-specific. function GetUniformBufferSize(const aName: string): Integer; procedure UseProgramObject; procedure EndUseProgramObject; procedure SetUniformi(const index: string; const val: Integer); overload; procedure SetUniformi(const index: string; const val: TVector2i); overload; procedure SetUniformi(const index: string; const val: TVector3i); overload; procedure SetUniformi(const index: string; const val: TVector4i); overload; procedure SetUniformf(const index: string; const val: Single); overload; procedure SetUniformf(const index: string; const val: TVector2f); overload; procedure SetUniformf(const index: string; const val: TVector3f); overload; procedure SetUniformf(const index: string; const val: TVector4f); overload; // Shader parameters. property Uniform1i[const index: string]: Integer read GetUniform1i write SetUniform1i; property Uniform2i[const index: string]: TVector2i read GetUniform2i write SetUniform2i; property Uniform3i[const index: string]: TVector3i read GetUniform3i write SetUniform3i; property Uniform4i[const index: string]: TVector4i read GetUniform4i write SetUniform4i; property Uniform1f[const index: string]: Single read GetUniform1f write SetUniform1f; property Uniform2f[const index: string]: TVector2f read GetUniform2f write SetUniform2f; property Uniform3f[const index: string]: TAffineVector read GetUniform3f write SetUniform3f; property Uniform4f[const index: string]: TGLVector read GetUniform4f write SetUniform4f; property UniformMatrix2fv[const index: string]: TMatrix2f read GetUniformMatrix2fv write SetUniformMatrix2fv; property UniformMatrix3fv[const index: string]: TMatrix3f read GetUniformMatrix3fv write SetUniformMatrix3fv; property UniformMatrix4fv[const index: string]: TGLMatrix read GetUniformMatrix4fv write SetUniformMatrix4fv; property UniformTextureHandle[const index: string; const TextureIndex: Integer; const TextureTarget: TGLTextureTarget] : TGLuint read GetUniformTextureHandle write SetUniformTextureHandle; property UniformBuffer[const index: string]: TGLUniformBufferHandle write SetUniformBuffer; end; TGLContextNotification = record obj: TObject; Event: TNotifyEvent; end; // Stores and manages all the TGLContext objects. TGLContextManager = class private FList: TThreadList; FTerminated: Boolean; FNotifications: array of TGLContextNotification; FCreatedRCCount: Integer; {$IFDEF USE_MULTITHREAD} FHandles: TThreadList; {$ELSE} FHandles: TList; {$ENDIF USE_MULTITHREAD} {$IFDEF USE_SERVICE_CONTEXT} FThread: TThread; FServiceStarter: TEvent; FThreadTask: TServiceContextTaskList; {$ENDIF} FServiceContext: TGLContext; protected procedure Lock; procedure UnLock; procedure RegisterContext(aContext: TGLContext); procedure UnRegisterContext(aContext: TGLContext); procedure ContextCreatedBy(aContext: TGLContext); procedure DestroyingContextBy(aContext: TGLContext); {$IFDEF USE_SERVICE_CONTEXT} // Create a special service and resource-keeper context. procedure CreateServiceContext; procedure QueueTaskDepleted; property ServiceStarter: TEvent read FServiceStarter; {$ENDIF} property ServiceContext: TGLContext read FServiceContext; public constructor Create; destructor Destroy; override; (* Returns an appropriate, ready-to use context. The returned context should be freed by caller. *) function CreateContext(AClass: TGLContextClass = nil): TGLContext; (* Returns the number of TGLContext object. This is *not* the number of OpenGL rendering contexts! *) function ContextCount: Integer; (* Registers a new object to notify when the last context is destroyed. When the last rendering context is destroyed, the 'anEvent' will be invoked with 'anObject' as parameter. Note that the registration is kept until the notification is triggered or a RemoveNotification on 'anObject' is issued. *) procedure LastContextDestroyNotification(anObject: TObject; anEvent: TNotifyEvent); // Unregisters an object from the notification lists. procedure RemoveNotification(anObject: TObject); // Marks the context manager for termination procedure Terminate; // Request all contexts to destroy all their handles. procedure DestroyAllHandles; // Notify all contexts about necessity of handles preparation. procedure NotifyPreparationNeed; end; EGLContext = class(Exception); EGLShader = class(EGLContext); EPBuffer = class(Exception); // Drivers should register themselves via this function. procedure RegisterGLContextClass(aGLContextClass: TGLContextClass); (* The TGLContext that is the currently active context, if any. Returns nil if no context is active. *) function CurrentGLContext: TGLContext; inline; function SafeCurrentGLContext: TGLContext; inline; function IsMainThread: Boolean; function IsServiceContextAvaible: Boolean; function GetServiceWindow: TForm; {$IFDEF USE_SERVICE_CONTEXT} procedure AddTaskForServiceContext(ATask: TTaskProcedure; FinishEvent: TFinishTaskEvent = nil); {$ENDIF} var GLContextManager: TGLContextManager; vIgnoreOpenGLErrors: Boolean = False; vContextActivationFailureOccurred: Boolean = False; {$IFDEF USE_MULTITHREAD} threadvar {$ELSE} var {$ENDIF} vCurrentGLContext: TGLContext; GL: TGLExtensionsAndEntryPoints; xgl: TGLMultitextureCoordinator; vMainThread: Boolean; GLwithoutContext: TGLExtensionsAndEntryPoints; // ------------------------------------------------------------------ implementation // ------------------------------------------------------------------ {$IFDEF USE_SERVICE_CONTEXT} type TServiceContextThread = class(TThread) private FDC: HDC; FWindow: TForm; FLastTaskStartTime: Double; FReported: Boolean; protected procedure Execute; override; procedure DoCreateServiceContext; stdcall; public constructor Create; destructor Destroy; override; end; {$ENDIF} var vContextClasses: TList; vServiceWindow: TForm; {$IFDEF USE_SERVICE_CONTEXT} OldInitProc: Pointer; {$ENDIF} function CurrentGLContext: TGLContext; inline; begin Result := vCurrentGLContext; end; function SafeCurrentGLContext: TGLContext; inline; begin Result := CurrentGLContext; if not Assigned(Result) then begin {$IFDEF USE_LOGGING} LogError(strNoActiveRC); {$ENDIF} Abort; end; end; function IsMainThread: Boolean; begin Result := vMainThread; end; function IsServiceContextAvaible: Boolean; begin Result := GLContextManager.ServiceContext <> nil; end; function GetServiceWindow: TForm; begin Result := vServiceWindow; end; procedure RegisterGLContextClass(aGLContextClass: TGLContextClass); begin if not Assigned(vContextClasses) then vContextClasses := TList.Create; vContextClasses.Add(aGLContextClass); end; // ------------------ // ------------------ TGLContext ------------------ // ------------------ constructor TGLContext.Create; begin inherited Create; {$IFDEF USE_MULTITHREAD} FLock := TCriticalSection.Create; {$ENDIF} FColorBits := 32; FStencilBits := 0; FAccumBits := 0; FAuxBuffers := 0; FLayer := clMainPlane; FOptions := []; {$IFNDEF USE_MULTITHREAD} FSharedContexts := TList.Create; {$ELSE} FSharedContexts := TThreadList.Create; {$ENDIF} FSharedContexts.Add(Self); FAcceleration := chaUnknown; FGLStates := TGLStateCache.Create; FGL := TGLExtensionsAndEntryPoints.Create; FTransformation := TGLTransformation.Create; FTransformation.LoadMatricesEnabled := True; GLContextManager.RegisterContext(Self); FIsPraparationNeed := True; FXGL := TGLMultitextureCoordinator.Create; end; destructor TGLContext.Destroy; begin if IsValid then DestroyContext; GLContextManager.UnRegisterContext(Self); FGLStates.Free; FGL.Free; FXGL.Free; FTransformation.Free; FSharedContexts.Free; {$IFDEF USE_MULTITHREAD} FLock.Free; {$ENDIF} inherited Destroy; end; procedure TGLContext.SetColorBits(const aColorBits: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FColorBits := aColorBits; end; procedure TGLContext.SetAlphaBits(const aAlphaBits: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FAlphaBits := aAlphaBits; end; procedure TGLContext.SetDepthBits(const val: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FDepthBits := val; end; procedure TGLContext.SetLayer(const Value: TGLContextLayer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FLayer := Value; end; procedure TGLContext.SetStencilBits(const aStencilBits: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FStencilBits := aStencilBits; end; procedure TGLContext.SetAccumBits(const aAccumBits: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FAccumBits := aAccumBits; end; procedure TGLContext.SetAuxBuffers(const aAuxBuffers: Integer); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FAuxBuffers := aAuxBuffers; end; procedure TGLContext.SetOptions(const aOptions: TGLRCOptions); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FOptions := aOptions; end; procedure TGLContext.SetAntiAliasing(const val: TGLAntiAliasing); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FAntiAliasing := val; end; procedure TGLContext.SetAcceleration(const val: TGLContextAcceleration); begin if Active then raise EGLContext.Create(strCannotAlterAnActiveContext) else FAcceleration := val; end; function TGLContext.GetActive: Boolean; begin Result := (FActivationCount > 0); end; procedure TGLContext.SetActive(const aActive: Boolean); begin // activation/deactivation can be nested... while aActive <> Active do begin if aActive then Activate else Deactivate; end; end; procedure TGLContext.CreateContext(ADeviceHandle: HDC); begin if IsValid then raise EGLContext.Create(strContextAlreadyCreated); DoCreateContext(ADeviceHandle); Manager.ContextCreatedBy(Self); end; procedure TGLContext.CreateMemoryContext(outputDevice: HWND; Width, Height: Integer; BufferCount: Integer); begin if IsValid then raise EGLContext.Create(strContextAlreadyCreated); DoCreateMemoryContext(outputDevice, width, height, BufferCount); Manager.ContextCreatedBy(Self); end; procedure TGLContext.PrepareHandlesData; var I: Integer; LHandle: TGLContextHandle; begin if vCurrentGLContext = Self then begin {$IFNDEF USE_MULTITHREAD} for I := Manager.FHandles.Count - 1 downto 0 do begin LHandle := TGLContextHandle(Manager.FHandles[I]); if Assigned(LHandle.FOnPrepare) then LHandle.FOnPrepare(Self); end; {$ELSE} with Manager.FHandles.LockList do try for I := Count - 1 downto 0 do begin LHandle := TGLContextHandle(Items[I]); if Assigned(LHandle.FOnPrepare) then LHandle.FOnPrepare(Self); end; finally Manager.FHandles.UnlockList; end; {$ENDIF} FIsPraparationNeed := False; end; end; procedure TGLContext.PropagateSharedContext; var I, j: Integer; otherContext: TGLContext; otherList: TList; begin {$IFNDEF USE_MULTITHREAD} with FSharedContexts do begin for I := 1 to Count - 1 do begin otherContext := TGLContext(Items[I]); otherList := otherContext.FSharedContexts; for j := 0 to otherList.Count - 1 do if IndexOf(otherList[j]) < 0 then Add(otherList[j]); end; for I := 1 to Count - 1 do begin otherContext := TGLContext(Items[I]); otherList := otherContext.FSharedContexts; if otherList.IndexOf(Self) < 0 then otherList.Add(Self); end; end; {$ELSE} with FSharedContexts.LockList do try for I := 1 to Count - 1 do begin otherContext := TGLContext(Items[I]); otherList := otherContext.FSharedContexts.LockList; for j := 0 to otherList.Count - 1 do if IndexOf(otherList[j]) < 0 then Add(otherList[j]); otherContext.FSharedContexts.UnlockList; end; for I := 1 to Count - 1 do begin otherContext := TGLContext(Items[I]); otherList := otherContext.FSharedContexts.LockList; if otherList.IndexOf(Self) < 0 then otherList.Add(Self); otherContext.FSharedContexts.UnlockList; end; finally FSharedContexts.UnlockList; end; {$ENDIF} end; procedure TGLContext.ShareLists(aContext: TGLContext); begin {$IFNDEF USE_MULTITHREAD} if FSharedContexts.IndexOf(aContext) < 0 then begin if DoShareLists(aContext) then begin FSharedContexts.Add(aContext); PropagateSharedContext; end; end; {$ELSE} with FSharedContexts.LockList do try if IndexOf(aContext) < 0 then begin if DoShareLists(aContext) then begin Add(aContext); PropagateSharedContext; end; end; finally FSharedContexts.UnlockList; end; {$ENDIF} end; procedure TGLContext.DestroyAllHandles; var I: Integer; begin Activate; try {$IFNDEF USE_MULTITHREAD} for I := Manager.FHandles.Count - 1 downto 0 do TGLContextHandle(Manager.FHandles[I]).ContextDestroying; {$ELSE} with Manager.FHandles.LockList do try for I := Count - 1 downto 0 do TGLContextHandle(Items[I]).ContextDestroying; finally Manager.FHandles.UnlockList; end; {$ENDIF} finally Deactivate; end; end; procedure TGLContext.DestroyContext; var I: Integer; oldContext, otherContext: TGLContext; contextHandle: TGLContextHandle; aList: TList; begin if vCurrentGLContext <> Self then begin oldContext := vCurrentGLContext; if Assigned(oldContext) then oldContext.Deactivate; end else oldContext := nil; Activate; try {$IFNDEF USE_MULTITHREAD} for I := Manager.FHandles.Count - 1 downto 0 do begin contextHandle := TGLContextHandle(Manager.FHandles[I]); contextHandle.ContextDestroying; end; {$ELSE} aList := Manager.FHandles.LockList; try for I := aList.Count - 1 downto 0 do begin contextHandle := TGLContextHandle(aList[I]); contextHandle.ContextDestroying; end; finally Manager.FHandles.UnlockList; end; {$ENDIF} Manager.DestroyingContextBy(Self); {$IFDEF USE_MULTITHREAD} aList := FSharedContexts.LockList; {$ELSE} aList := FSharedContexts; {$ENDIF} for I := 1 to aList.Count - 1 do begin otherContext := TGLContext(aList[I]); otherContext.FSharedContexts.Remove(Self); end; FSharedContexts.Clear; FSharedContexts.Add(Self); {$IFDEF USE_MULTITHREAD} FSharedContexts.UnlockList; {$ENDIF} Active := False; DoDestroyContext; finally if Assigned(oldContext) then oldContext.Activate; end; FAcceleration := chaUnknown; FGL.Close; end; procedure TGLContext.Activate; begin {$IFDEF USE_MULTITHREAD} FLock.Enter; {$ENDIF} if FActivationCount = 0 then begin if not IsValid then raise EGLContext.Create(strContextNotCreated); vContextActivationFailureOccurred := False; try DoActivate; except vContextActivationFailureOccurred := True; end; GLS.Context.GL := FGL; xgl := FXGL; vCurrentGLContext := Self; end else Assert(vCurrentGLContext = Self, 'vCurrentGLContext <> Self'); Inc(FActivationCount); end; procedure TGLContext.Deactivate; begin Assert(vCurrentGLContext = Self); Dec(FActivationCount); if FActivationCount = 0 then begin if not IsValid then raise EGLContext.Create(strContextNotCreated); if not vContextActivationFailureOccurred then DoDeactivate; vCurrentGLContext := nil; GLS.Context.GL := GLwithoutContext; xgl := nil; end else if FActivationCount < 0 then raise EGLContext.Create(strUnbalancedContexActivations); {$IFDEF USE_MULTITHREAD} FLock.Leave; {$ENDIF} end; function TGLContext.FindCompatibleContext: TGLContext; var I: Integer; begin Result := nil; {$IFNDEF USE_MULTITHREAD} for I := 0 to FSharedContexts.Count - 1 do if TGLContext(FSharedContexts[I]) <> Self then begin Result := TGLContext(FSharedContexts[I]); Break; end; {$ELSE} with FSharedContexts.LockList do try for I := 0 to Count - 1 do if TGLContext(Items[I]) <> Self then begin Result := TGLContext(Items[I]); Break; end; finally FSharedContexts.UnlockList; end; {$ENDIF} end; class function TGLContext.ServiceContext: TGLContext; begin Result := GLContextManager.FServiceContext; end; procedure TGLContext.MakeGLCurrent; begin GLS.Context.GL := FGL; end; // ------------------ // ------------------ TGLContextHandle ------------------ // ------------------ constructor TGLContextHandle.Create; begin inherited Create; FHandles := TList.Create; // first is a dummy record new(FLastHandle); FillChar(FLastHandle^, sizeof(FLastHandle^), 0); FHandles.Add(FLastHandle); GLContextManager.FHandles.Add(Self); end; constructor TGLContextHandle.CreateAndAllocate(failIfAllocationFailed: Boolean = True); begin Create; AllocateHandle; if failIfAllocationFailed and (Handle = 0) then raise EGLContext.Create('Auto-allocation failed'); end; destructor TGLContextHandle.Destroy; var I: Integer; begin DestroyHandle; for I := 0 to FHandles.Count - 1 do Dispose(RCItem(I)); FHandles.Free; if Assigned(GLContextManager) then GLContextManager.FHandles.Remove(Self); inherited Destroy; end; function TGLContextHandle.AllocateHandle: Cardinal; var I: Integer; bSucces: Boolean; aList: TList; p: PGLRCHandle; begin // if handle aready allocated in current context Result := GetHandle; if Result <> 0 then exit; if vCurrentGLContext = nil then begin {$IFDEF USE_LOGGING} GLSLogger.LogError('Failed to allocate OpenGL identifier - no active rendering context!'); {$ENDIF} exit; end; // add entry new(FLastHandle); FillChar(FLastHandle^, sizeof(FLastHandle^), 0); FHandles.Add(FLastHandle); FLastHandle.FRenderingContext := vCurrentGLContext; bSucces := False; if Transferable then begin {$IFNDEF USE_MULTITHREAD} aList := vCurrentGLContext.FSharedContexts; {$ELSE} aList := vCurrentGLContext.FSharedContexts.LockList; try {$ENDIF} for I := aList.Count - 1 downto 0 do begin p := SearchRC(aList[I]); if (p.FHandle > 0) then begin // Copy shared handle // FLastHandle.FRenderingContext := vCurrentGLContext; FLastHandle.FHandle := p.FHandle; FLastHandle.FChanged := p.FChanged; Inc(vCurrentGLContext.FOwnedHandlesCount); bSucces := True; Break; end; end; {$IFNDEF USE_MULTITHREAD} {$ELSE} finally vCurrentGLContext.FSharedContexts.UnlockList; end; {$ENDIF} end; if not bSucces then begin // Allocate handle in current context FLastHandle.FHandle := DoAllocateHandle; bSucces := FLastHandle.FHandle <> 0; FLastHandle.FChanged := bSucces; if bSucces then Inc(vCurrentGLContext.FOwnedHandlesCount); end; Result := FLastHandle.FHandle; if not bSucces then GLSLogger.LogError(strNoActiveRC) else if Assigned(FOnPrepare) then GLContextManager.NotifyPreparationNeed; end; function TGLContextHandle.IsAllocatedForContext(aContext: TGLContext = nil): Boolean; begin Result := SearchRC(aContext).FHandle > 0; end; function TGLContextHandle.SearchRC(aContext: TGLContext): PGLRCHandle; var I: Integer; begin if aContext = nil then aContext := vCurrentGLContext; if aContext = FLastHandle.FRenderingContext then begin Result := FLastHandle; exit; end; for I := 1 to FHandles.Count - 1 do if RCItem(I).FRenderingContext = aContext then begin Result := RCItem(I); exit; end; // first handle is always a dummy Result := FHandles[0]; end; procedure TGLContextHandle.CheckCurrentRC; begin if vCurrentGLContext <> FLastHandle.FRenderingContext then FLastHandle := SearchRC(vCurrentGLContext); end; function TGLContextHandle.GetHandle: Cardinal; begin // CheckCurrentRC; // inline doesn't always work... so optimize it here if vCurrentGLContext <> FLastHandle.FRenderingContext then FLastHandle := SearchRC(vCurrentGLContext); Result := FLastHandle.FHandle; end; procedure TGLContextHandle.DestroyHandle; var oldContext: TGLContext; p: PGLRCHandle; I: Integer; begin oldContext := vCurrentGLContext; if Assigned(oldContext) then oldContext.Deactivate; try for I := FHandles.Count - 1 downto 1 do begin p := FHandles[I]; if p.FHandle > 0 then begin p.FRenderingContext.Activate; if IsValid(p.FHandle) then DoDestroyHandle(p.FHandle); Dec(p.FRenderingContext.FOwnedHandlesCount); p.FRenderingContext.Deactivate; p.FRenderingContext := nil; p.FHandle := 0; p.FChanged := True; end; Dispose(p); end; FHandles.Count := 1; // delete all in 1 step FLastHandle := FHandles[0]; finally if Assigned(vCurrentGLContext) then vCurrentGLContext.Deactivate; if Assigned(oldContext) then oldContext.Activate; end; end; procedure TGLContextHandle.ContextDestroying; var I: Integer; p: PGLRCHandle; aList: TList; bShared: Boolean; begin if Assigned(vCurrentGLContext) then begin bShared := False; if Transferable then begin {$IFNDEF USE_MULTITHREAD} aList := vCurrentGLContext.FSharedContexts; {$ELSE} aList := vCurrentGLContext.FSharedContexts.LockList; try {$ENDIF USE_MULTITHREAD} for I := FHandles.Count - 1 downto 1 do begin p := RCItem(I); if (p.FRenderingContext <> vCurrentGLContext) and (p.FHandle <> 0) and (aList.IndexOf(p.FRenderingContext) > -1) then begin bShared := True; Break; end; end; {$IFDEF USE_MULTITHREAD} finally vCurrentGLContext.FSharedContexts.UnlockList; end; {$ENDIF USE_MULTITHREAD} end; for I := FHandles.Count - 1 downto 1 do begin p := RCItem(I); if (p.FRenderingContext = vCurrentGLContext) and (p.FHandle <> 0) then begin if not bShared then if IsValid(p.FHandle) then DoDestroyHandle(p.FHandle); Dec(p.FRenderingContext.FOwnedHandlesCount); p.FHandle := 0; p.FRenderingContext := nil; p.FChanged := True; Dispose(p); FHandles.Delete(I); if FLastHandle = p then FLastHandle := FHandles[0]; exit; end; end; end; end; function TGLContextHandle.GetContext: TGLContext; var I: Integer; p: PGLRCHandle; begin Result := nil; // Return first context where handle is allocated for I := FHandles.Count - 1 downto 1 do begin p := RCItem(I); if (p.FRenderingContext <> nil) and (p.FHandle <> 0) then begin Result := p.FRenderingContext; // If handle allocated in active context - return it if (Result = vCurrentGLContext) then exit; end; end; end; function TGLContextHandle.IsDataNeedUpdate: Boolean; begin if GetHandle = 0 then CheckCurrentRC; Result := (FLastHandle.FHandle = 0) or FLastHandle.FChanged; end; function TGLContextHandle.IsDataComplitelyUpdated: Boolean; var I: Integer; begin Result := False; for I := FHandles.Count - 1 downto 1 do begin with RCItem(I)^ do if (FRenderingContext <> nil) and (FHandle <> 0) and FChanged then exit; end; Result := True; end; procedure TGLContextHandle.NotifyDataUpdated; var I: Integer; aList: TList; begin if Assigned(vCurrentGLContext) then begin if not Transferable then begin CheckCurrentRC(); if FLastHandle.FHandle <> 0 then begin FLastHandle.FChanged := False; exit; end; end else begin {$IFNDEF USE_MULTITHREAD} aList := vCurrentGLContext.FSharedContexts; {$ELSE} aList := vCurrentGLContext.FSharedContexts.LockList; try {$ENDIF} for I := 0 to aList.Count - 1 do begin with SearchRC(aList[I])^ do if (FHandle <> 0) then FChanged := False; end; {$IFDEF USE_MULTITHREAD} finally vCurrentGLContext.FSharedContexts.UnlockList; end; {$ENDIF} end; end {$IFDEF USE_LOGGING} else GLSLogger.LogError(strNoActiveRC); {$ENDIF} end; function TGLContextHandle.RCItem(AIndex: Integer): PGLRCHandle; begin Result := FHandles[AIndex]; end; procedure TGLContextHandle.NotifyChangesOfData; var I: Integer; begin for I := FHandles.Count - 1 downto 1 do RCItem(I).FChanged := True; if Assigned(FOnPrepare) then GLContextManager.NotifyPreparationNeed; end; function TGLContextHandle.IsShared: Boolean; var I: Integer; vContext: TGLContext; aList: TList; begin Result := False; // untransferable handles can't be shared if not Transferable then exit; Result := True; {$IFNDEF USE_MULTITHREAD} aList := vCurrentGLContext.FSharedContexts; {$ELSE} aList := vCurrentGLContext.FSharedContexts.LockList; try {$ENDIF} for I := 0 to aList.Count - 1 do begin vContext := aList[I]; if (vContext <> vCurrentGLContext) and // at least one context is friendly (SearchRC(vContext).FHandle <> 0) then exit; end; {$IFDEF USE_MULTITHREAD} finally vCurrentGLContext.FSharedContexts.UnlockList; end; {$ENDIF} Result := False; end; class function TGLContextHandle.Transferable: Boolean; begin Result := True; end; class function TGLContextHandle.IsValid(const ID: Cardinal): Boolean; begin Result := True; end; class function TGLContextHandle.IsSupported: Boolean; begin Result := True; end; // ------------------ // ------------------ TGLVirtualHandle ------------------ // ------------------ function TGLVirtualHandle.DoAllocateHandle: Cardinal; begin Result := 0; if Assigned(FOnAllocate) then FOnAllocate(Self, Result); end; procedure TGLVirtualHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.ClearError; if Assigned(FOnDestroy) then FOnDestroy(Self, AHandle); gl.CheckError; end; end; class function TGLVirtualHandle.Transferable: Boolean; begin Result := False; end; // ------------------ // TGLVirtualHandleTransf // ------------------ class function TGLVirtualHandleTransf.Transferable: Boolean; begin Result := True; end; // ------------------ // ------------------ TGLListHandle ------------------ // ------------------ function TGLListHandle.DoAllocateHandle: Cardinal; begin Result := gl.GenLists(1); end; procedure TGLListHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.ClearError; gl.DeleteLists(AHandle, 1); gl.CheckError; end; end; class function TGLListHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsList(ID); end; procedure TGLListHandle.NewList(mode: Cardinal); begin vCurrentGLContext.GLStates.NewList(GetHandle, mode); end; procedure TGLListHandle.EndList; begin vCurrentGLContext.GLStates.EndList; end; procedure TGLListHandle.CallList; begin vCurrentGLContext.GLStates.CallList(GetHandle); end; // ------------------ // ------------------ TGLTextureHandle ------------------ // ------------------ function TGLTextureHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenTextures(1, @Result); FTarget := ttNoShape; end; procedure TGLTextureHandle.DoDestroyHandle(var AHandle: Cardinal); var a: TGLInt; t: TGLTextureTarget; begin if not vContextActivationFailureOccurred then begin gl.GetError; // Unbind identifier from all image selectors. if gl.ARB_multitexture then begin with GetContext.GLStates do begin for a := 0 to MaxTextureImageUnits - 1 do for t := Low(TGLTextureTarget) to High(TGLTextureTarget) do if TextureBinding[a, t] = AHandle then TextureBinding[a, t] := 0; end end else with GetContext.GLStates do for t := Low(TGLTextureTarget) to High(TGLTextureTarget) do if TextureBinding[0, t] = AHandle then TextureBinding[0, t] := 0; gl.DeleteTextures(1, @AHandle); gl.CheckError; end; end; class function TGLTextureHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsTexture(ID); end; procedure TGLTextureHandle.SetTarget(ATarget: TGLTextureTarget); begin if FTarget = ttNoShape then FTarget := ATarget; end; // ------------------ // ------------------ TGLSamplerHandle ------------------ // ------------------ function TGLSamplerHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenSamplers(1, @Result); end; procedure TGLSamplerHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeleteSamplers(1, @AHandle); gl.CheckError; end; end; class function TGLSamplerHandle.IsSupported: Boolean; begin Result := gl.ARB_sampler_objects; end; class function TGLSamplerHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsSampler(ID); end; // ------------------ // ------------------ TGLQueryHandle ------------------ // ------------------ procedure TGLQueryHandle.BeginQuery; begin if vCurrentGLContext.GLStates.CurrentQuery[QueryType] = 0 then vCurrentGLContext.GLStates.BeginQuery(QueryType, GetHandle); FActive := True; end; function TGLQueryHandle.CounterBits: Integer; begin gl.GetQueryiv(Target, GL_QUERY_COUNTER_BITS, @Result); end; function TGLQueryHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenQueries(1, @Result); end; procedure TGLQueryHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeleteQueries(1, @AHandle); gl.CheckError; end; end; class function TGLQueryHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsQuery(ID); end; procedure TGLQueryHandle.EndQuery; begin Assert(FActive = True, 'Cannot end a query before it begins'); FActive := False; Assert(Handle <> 0); // glEndQuery(Target); vCurrentGLContext.GLStates.EndQuery(QueryType); end; function TGLQueryHandle.IsResultAvailable: Boolean; begin gl.GetQueryObjectiv(Handle, GL_QUERY_RESULT_AVAILABLE, @Result); end; function TGLQueryHandle.QueryResultInt: TGLInt; begin gl.GetQueryObjectiv(Handle, GL_QUERY_RESULT, @Result); end; function TGLQueryHandle.QueryResultInt64: TGLint64EXT; begin gl.GetQueryObjecti64v(Handle, GL_QUERY_RESULT, @Result); end; function TGLQueryHandle.QueryResultUInt: Cardinal; begin gl.GetQueryObjectuiv(Handle, GL_QUERY_RESULT, @Result); end; function TGLQueryHandle.QueryResultUInt64: TGLuint64EXT; begin gl.GetQueryObjectui64v(Handle, GL_QUERY_RESULT, @Result); end; function TGLQueryHandle.QueryResultBool: TGLboolean; var I: Cardinal; begin gl.GetQueryObjectuiv(Handle, GL_QUERY_RESULT, @I); Result := I > 0; end; class function TGLQueryHandle.Transferable: Boolean; begin Result := False; end; // ------------------ // ------------------ TGLOcclusionQueryHandle ------------------ // ------------------ function TGLOcclusionQueryHandle.GetQueryType: TGLQueryType; begin Result := qrySamplesPassed; end; function TGLOcclusionQueryHandle.GetTarget: Cardinal; begin Result := GL_SAMPLES_PASSED; end; class function TGLOcclusionQueryHandle.IsSupported: Boolean; begin Result := gl.VERSION_1_5; end; function TGLOcclusionQueryHandle.PixelCount: Integer; begin Result := QueryResultUInt; end; // ------------------ // ------------------ TGLBooleanOcclusionQueryHandle ------------------ // ------------------ function TGLBooleanOcclusionQueryHandle.GetQueryType: TGLQueryType; begin Result := qryAnySamplesPassed; end; function TGLBooleanOcclusionQueryHandle.GetTarget: Cardinal; begin Result := GL_ANY_SAMPLES_PASSED; end; class function TGLBooleanOcclusionQueryHandle.IsSupported: Boolean; begin Result := gl.ARB_occlusion_query2; end; // ------------------ // ------------------ TGLTimerQueryHandle ------------------ // ------------------ function TGLTimerQueryHandle.GetQueryType: TGLQueryType; begin Result := qryTimeElapsed; end; function TGLTimerQueryHandle.GetTarget: Cardinal; begin Result := GL_TIME_ELAPSED; end; class function TGLTimerQueryHandle.IsSupported: Boolean; begin Result := gl.EXT_timer_query or gl.ARB_timer_query; end; function TGLTimerQueryHandle.Time: Integer; begin Result := QueryResultUInt; end; // ------------------ // ------------------ TGLPrimitiveQueryHandle ------------------ // ------------------ function TGLPrimitiveQueryHandle.GetQueryType: TGLQueryType; begin Result := qryPrimitivesGenerated; end; function TGLPrimitiveQueryHandle.GetTarget: Cardinal; begin Result := GL_PRIMITIVES_GENERATED; end; class function TGLPrimitiveQueryHandle.IsSupported: Boolean; begin Result := gl.VERSION_3_0; end; function TGLPrimitiveQueryHandle.PrimitivesGenerated: Integer; begin Result := QueryResultUInt; end; // ------------------ // ------------------ TGLBufferObjectHandle ------------------ // ------------------ constructor TGLBufferObjectHandle.CreateFromData(p: Pointer; size: Integer; bufferUsage: Cardinal); begin Create; AllocateHandle; Bind; BufferData(p, size, bufferUsage); UnBind; end; function TGLBufferObjectHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenBuffers(1, @Result); end; procedure TGLBufferObjectHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; UnBind; gl.DeleteBuffers(1, @AHandle); gl.CheckError; end; end; class function TGLBufferObjectHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsBuffer(ID); end; class function TGLBufferObjectHandle.IsSupported: Boolean; begin Result := gl.ARB_vertex_buffer_object; end; procedure TGLBufferObjectHandle.BindRange(index: Cardinal; offset: TGLintptr; size: TGLsizeiptr); begin Assert(False, 'BindRange only XBO and UBO'); end; procedure TGLBufferObjectHandle.BindBase(index: Cardinal); begin Assert(False, 'BindRange only XBO and UBO'); end; procedure TGLBufferObjectHandle.UnBindBase(index: Cardinal); begin Assert(False, 'BindRange only XBO and UBO'); end; procedure TGLBufferObjectHandle.BufferData(p: Pointer; size: Integer; bufferUsage: Cardinal); begin FSize := size; gl.BufferData(Target, size, p, bufferUsage); end; procedure TGLBufferObjectHandle.BindBufferData(p: Pointer; size: Integer; bufferUsage: Cardinal); begin Bind; FSize := size; gl.BufferData(Target, size, p, bufferUsage); end; procedure TGLBufferObjectHandle.BufferSubData(offset, size: Integer; p: Pointer); begin Assert(offset + size <= FSize); gl.BufferSubData(Target, offset, size, p); end; function TGLBufferObjectHandle.MapBuffer(access: Cardinal): Pointer; begin Result := gl.MapBuffer(Target, access); end; function TGLBufferObjectHandle.MapBufferRange(offset: TGLInt; len: TGLsizei; access: TGLbitfield): Pointer; begin Result := gl.MapBufferRange(Target, offset, len, access); end; procedure TGLBufferObjectHandle.Flush(offset: TGLInt; len: TGLsizei); begin gl.FlushMappedBufferRange(Target, offset, len); end; function TGLBufferObjectHandle.UnmapBuffer: Boolean; begin Result := gl.UnmapBuffer(Target); end; // ------------------ // ------------------ TGLVBOHandle ------------------ // ------------------ function TGLVBOHandle.GetVBOTarget: Cardinal; begin Result := Target; end; // ------------------ // ------------------ TGLVBOArrayBufferHandle ------------------ // ------------------ procedure TGLVBOArrayBufferHandle.Bind; begin vCurrentGLContext.GLStates.ArrayBufferBinding := Handle; end; procedure TGLVBOArrayBufferHandle.UnBind; begin vCurrentGLContext.GLStates.ArrayBufferBinding := 0; end; function TGLVBOArrayBufferHandle.GetTarget: Cardinal; begin Result := GL_ARRAY_BUFFER; end; // ------------------ // ------------------ TGLVBOElementArrayHandle ------------------ // ------------------ procedure TGLVBOElementArrayHandle.Bind; begin vCurrentGLContext.GLStates.ElementBufferBinding := Handle; end; procedure TGLVBOElementArrayHandle.UnBind; begin vCurrentGLContext.GLStates.ElementBufferBinding := 0; end; function TGLVBOElementArrayHandle.GetTarget: TGLuint; begin Result := GL_ELEMENT_ARRAY_BUFFER; end; // ------------------ // ------------------ TGLPackPBOHandle ------------------ // ------------------ procedure TGLPackPBOHandle.Bind; begin vCurrentGLContext.GLStates.PixelPackBufferBinding := Handle; end; procedure TGLPackPBOHandle.UnBind; begin vCurrentGLContext.GLStates.PixelPackBufferBinding := 0; end; function TGLPackPBOHandle.GetTarget: TGLuint; begin Result := GL_PIXEL_PACK_BUFFER; end; class function TGLPackPBOHandle.IsSupported: Boolean; begin Result := GL.ARB_pixel_buffer_object; end; // ------------------ // ------------------ TGLUnpackPBOHandle ------------------ // ------------------ procedure TGLUnpackPBOHandle.Bind; begin vCurrentGLContext.GLStates.PixelUnpackBufferBinding := Handle; end; procedure TGLUnpackPBOHandle.UnBind; begin vCurrentGLContext.GLStates.PixelUnpackBufferBinding := 0; end; function TGLUnpackPBOHandle.GetTarget: Cardinal; begin Result := GL_PIXEL_UNPACK_BUFFER; end; class function TGLUnpackPBOHandle.IsSupported: Boolean; begin Result := gl.ARB_pixel_buffer_object; end; // ------------------ // ------------------ TGLTransformFeedbackBufferHandle ------------------ // ------------------ procedure TGLTransformFeedbackBufferHandle.Bind; begin vCurrentGLContext.GLStates.TransformFeedbackBufferBinding := Handle; end; procedure TGLTransformFeedbackBufferHandle.UnBind; begin vCurrentGLContext.GLStates.TransformFeedbackBufferBinding := 0; end; function TGLTransformFeedbackBufferHandle.GetTarget: TGLuint; begin Result := GL_TRANSFORM_FEEDBACK_BUFFER; end; procedure TGLTransformFeedbackBufferHandle.BeginTransformFeedback (primitiveMode: TGLuint); begin gl.BeginTransformFeedback(primitiveMode); end; procedure TGLTransformFeedbackBufferHandle.EndTransformFeedback(); begin gl.EndTransformFeedback(); end; procedure TGLTransformFeedbackBufferHandle.BindRange(index: Cardinal; offset: TGLintptr; size: TGLsizeiptr); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(Handle, bbtTransformFeedBack, index, offset, size); end; procedure TGLTransformFeedbackBufferHandle.BindBase(index: Cardinal); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(Handle, bbtTransformFeedBack, index, BufferSize); end; procedure TGLTransformFeedbackBufferHandle.UnBindBase(index: Cardinal); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(0, bbtTransformFeedBack, index, 0); end; class function TGLTransformFeedbackBufferHandle.IsSupported: Boolean; begin Result := GL.EXT_transform_feedback; end; // ------------------ // ------------------ TGLTextureBufferHandle ------------------ // ------------------ procedure TGLTextureBufferHandle.Bind; begin vCurrentGLContext.GLStates.TextureBufferBinding := Handle; end; procedure TGLTextureBufferHandle.UnBind; begin vCurrentGLContext.GLStates.TextureBufferBinding := 0; end; function TGLTextureBufferHandle.GetTarget: Cardinal; begin Result := GL_TEXTURE_BUFFER; end; class function TGLTextureBufferHandle.IsSupported: Boolean; begin Result := gl.EXT_texture_buffer_object or gl.ARB_texture_buffer_object or gl.VERSION_3_1; end; // ------------------ // ------------------ TGLUniformBufferHandle ------------------ // ------------------ procedure TGLUniformBufferHandle.Bind; begin vCurrentGLContext.GLStates.UniformBufferBinding := Handle; end; procedure TGLUniformBufferHandle.UnBind; begin vCurrentGLContext.GLStates.UniformBufferBinding := 0; end; procedure TGLUniformBufferHandle.BindRange(index: Cardinal; offset: TGLintptr; size: TGLsizeiptr); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(Handle, bbtUniform, index, offset, size); end; procedure TGLUniformBufferHandle.BindBase(index: Cardinal); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(Handle, bbtUniform, index, BufferSize); end; procedure TGLUniformBufferHandle.UnBindBase(index: Cardinal); begin vCurrentGLContext.GLStates.SetBufferIndexedBinding(0, bbtUniform, index, 0); end; function TGLUniformBufferHandle.GetTarget: Cardinal; begin Result := GL_UNIFORM_BUFFER; end; class function TGLUniformBufferHandle.IsSupported: Boolean; begin Result := gl.ARB_uniform_buffer_object; end; // ------------------ // ------------------ TGLVertexArrayHandle ------------------ // ------------------ function TGLVertexArrayHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenVertexArrays(1, @Result); end; procedure TGLVertexArrayHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeleteVertexArrays(1, @AHandle); gl.CheckError; end; end; class function TGLVertexArrayHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsVertexArray(ID); end; procedure TGLVertexArrayHandle.Bind; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.VertexArrayBinding := Handle; end; procedure TGLVertexArrayHandle.UnBind; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.VertexArrayBinding := 0; end; class function TGLVertexArrayHandle.IsSupported: Boolean; begin Result := gl.ARB_vertex_array_object; end; class function TGLVertexArrayHandle.Transferable: Boolean; begin Result := False; end; // ------------------ // ------------------ TGLFramebufferHandle ------------------ // ------------------ function TGLFramebufferHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenFramebuffers(1, @Result) end; procedure TGLFramebufferHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeleteFramebuffers(1, @AHandle); gl.CheckError; end; end; class function TGLFramebufferHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsFramebuffer(ID); end; procedure TGLFramebufferHandle.Bind; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.SetFrameBuffer(Handle); end; procedure TGLFramebufferHandle.BindForDrawing; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.DrawFrameBuffer := Handle; end; procedure TGLFramebufferHandle.BindForReading; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.ReadFrameBuffer := Handle; end; procedure TGLFramebufferHandle.UnBind; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.SetFrameBuffer(0); end; procedure TGLFramebufferHandle.UnBindForDrawing; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.DrawFrameBuffer := 0; end; procedure TGLFramebufferHandle.UnBindForReading; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.ReadFrameBuffer := 0; end; procedure TGLFramebufferHandle.Attach1DTexture(Target: Cardinal; attachment: Cardinal; textarget: Cardinal; texture: Cardinal; level: TGLInt); begin gl.FramebufferTexture1D(Target, attachment, textarget, texture, level); end; procedure TGLFramebufferHandle.Attach2DTexture(Target: Cardinal; attachment: Cardinal; textarget: Cardinal; texture: Cardinal; level: TGLInt); begin gl.FramebufferTexture2D(Target, attachment, textarget, texture, level); end; procedure TGLFramebufferHandle.Attach3DTexture(Target: Cardinal; attachment: Cardinal; textarget: Cardinal; texture: Cardinal; level: TGLInt; Layer: TGLInt); begin gl.FramebufferTexture3D(Target, attachment, textarget, texture, level, Layer); end; procedure TGLFramebufferHandle.AttachLayer(Target: Cardinal; attachment: Cardinal; texture: Cardinal; level: TGLInt; Layer: TGLInt); begin gl.FramebufferTextureLayer(Target, attachment, texture, level, Layer); end; procedure TGLFramebufferHandle.AttachRenderBuffer(Target: Cardinal; attachment: Cardinal; renderbuffertarget: Cardinal; renderbuffer: Cardinal); begin gl.FramebufferRenderbuffer(Target, attachment, renderbuffertarget, renderbuffer); end; procedure TGLFramebufferHandle.AttachTexture(Target: Cardinal; attachment: Cardinal; texture: Cardinal; level: TGLInt); begin gl.FramebufferTexture(Target, attachment, texture, level); end; procedure TGLFramebufferHandle.AttachTextureLayer(Target: Cardinal; attachment: Cardinal; texture: Cardinal; level: TGLInt; Layer: TGLInt); begin gl.FramebufferTextureLayer(Target, attachment, texture, level, Layer); end; procedure TGLFramebufferHandle.Blit(srcX0: TGLInt; srcY0: TGLInt; srcX1: TGLInt; srcY1: TGLInt; dstX0: TGLInt; dstY0: TGLInt; dstX1: TGLInt; dstY1: TGLInt; mask: TGLbitfield; filter: Cardinal); begin gl.BlitFramebuffer(srcX0, srcY0, srcX1, srcY1, dstX0, dstY0, dstX1, dstY1, mask, filter); end; function TGLFramebufferHandle.GetAttachmentParameter(Target: Cardinal; attachment: Cardinal; pname: Cardinal): TGLInt; begin gl.GetFramebufferAttachmentParameteriv(Target, attachment, pname, @Result) end; function TGLFramebufferHandle.GetAttachmentObjectType(Target: Cardinal; attachment: Cardinal): TGLInt; begin gl.GetFramebufferAttachmentParameteriv(Target, attachment, GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE, @Result); end; function TGLFramebufferHandle.GetAttachmentObjectName(Target: Cardinal; attachment: Cardinal): TGLInt; begin gl.GetFramebufferAttachmentParameteriv(Target, attachment, GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME, @Result); end; function TGLFramebufferHandle.GetStatus: TGLFramebufferStatus; var Status: TGLuint; begin Status := gl.CheckFramebufferStatus(GL_FRAMEBUFFER); case Status of GL_FRAMEBUFFER_COMPLETE_EXT: Result := fsComplete; GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT: Result := fsIncompleteAttachment; GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT: Result := fsIncompleteMissingAttachment; GL_FRAMEBUFFER_INCOMPLETE_DUPLICATE_ATTACHMENT_EXT: Result := fsIncompleteDuplicateAttachment; GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT: Result := fsIncompleteDimensions; GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT: Result := fsIncompleteFormats; GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT: Result := fsIncompleteDrawBuffer; GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT: Result := fsIncompleteReadBuffer; GL_FRAMEBUFFER_UNSUPPORTED_EXT: Result := fsUnsupported; GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE: Result := fsIncompleteMultisample; else Result := fsStatusError; end; end; function TGLFramebufferHandle.GetStringStatus(out clarification: string): TGLFramebufferStatus; const cFBOStatus: array [TGLFramebufferStatus] of string = ('Complete', 'Incomplete attachment', 'Incomplete missing attachment', 'Incomplete duplicate attachment', 'Incomplete dimensions', 'Incomplete formats', 'Incomplete draw buffer', 'Incomplete read buffer', 'Unsupported', 'Incomplite multisample', 'Status Error'); begin Result := GetStatus; clarification := cFBOStatus[Result]; end; class function TGLFramebufferHandle.IsSupported: Boolean; begin Result := gl.EXT_framebuffer_object or gl.ARB_framebuffer_object; end; class function TGLFramebufferHandle.Transferable: Boolean; begin Result := False; end; // ------------------ // ------------------ TGLRenderbufferObject ------------------ // ------------------ function TGLRenderbufferHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenRenderbuffers(1, @Result); end; procedure TGLRenderbufferHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeleteRenderbuffers(1, @AHandle); gl.CheckError; end; end; class function TGLRenderbufferHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsRenderbuffer(ID); end; procedure TGLRenderbufferHandle.Bind; begin vCurrentGLContext.GLStates.renderbuffer := GetHandle; end; procedure TGLRenderbufferHandle.UnBind; begin if vCurrentGLContext <> nil then vCurrentGLContext.GLStates.renderbuffer := 0; end; procedure TGLRenderbufferHandle.SetStorage(internalformat: Cardinal; width, height: TGLsizei); begin gl.RenderbufferStorage(GL_RENDERBUFFER, internalformat, width, height); end; procedure TGLRenderbufferHandle.SetStorageMultisample(internalformat: Cardinal; samples: TGLsizei; width, height: TGLsizei); begin gl.RenderbufferStorageMultisample(GL_RENDERBUFFER, samples, internalformat, width, height); end; class function TGLRenderbufferHandle.IsSupported: Boolean; begin Result := gl.EXT_framebuffer_object or gl.ARB_framebuffer_object; end; // ------------------ // ------------------ TGLARBProgramHandle ------------------ // ------------------ function TGLARBProgramHandle.DoAllocateHandle: Cardinal; begin Result := 0; gl.GenPrograms(1, @Result); FReady := False; end; procedure TGLARBProgramHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.GetError; gl.DeletePrograms(1, @AHandle); gl.CheckError; end; end; class function TGLARBProgramHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsProgram(ID); end; procedure TGLARBProgramHandle.LoadARBProgram(const AText: string); const cProgType: array [0 .. 2] of string = ('ARB vertex', 'ARB fragment', 'NV geometry'); var errPos, p: Integer; begin Bind; gl.ProgramString(GetTarget, GL_PROGRAM_FORMAT_ASCII_ARB, Length(AText), PAnsiChar(AnsiString(AText))); gl.GetIntegerv(GL_PROGRAM_ERROR_POSITION_ARB, @errPos); if errPos > -1 then begin FInfoLog := string(gl.GetString(GL_PROGRAM_ERROR_STRING_ARB)); case GetTarget of GL_VERTEX_PROGRAM_ARB: p := 0; GL_FRAGMENT_PROGRAM_ARB: p := 1; else p := 2; end; GLSLogger.LogError(Format('%s Program Error - [Pos: %d][Error %s]', [cProgType[p], errPos, FInfoLog])); FReady := False; end else begin FReady := True; FInfoLog := ''; end; end; procedure TGLARBProgramHandle.Enable; begin if FReady then gl.Enable(GetTarget) else Abort; end; procedure TGLARBProgramHandle.Disable; begin gl.Disable(GetTarget); end; procedure TGLARBProgramHandle.Bind; begin gl.BindProgram(GetTarget, Handle); end; class function TGLARBVertexProgramHandle.GetTarget: Cardinal; begin Result := GL_VERTEX_PROGRAM_ARB; end; class function TGLARBVertexProgramHandle.IsSupported: Boolean; begin Result := gl.ARB_vertex_program; end; class function TGLARBFragmentProgramHandle.GetTarget: Cardinal; begin Result := GL_FRAGMENT_PROGRAM_ARB; end; class function TGLARBFragmentProgramHandle.IsSupported: Boolean; begin Result := gl.ARB_vertex_program; end; class function TGLARBGeometryProgramHandle.GetTarget: Cardinal; begin Result := GL_GEOMETRY_PROGRAM_NV; end; class function TGLARBGeometryProgramHandle.IsSupported: Boolean; begin Result := gl.NV_geometry_program4; end; // ------------------ // ------------------ TGLSLHandle ------------------ // ------------------ procedure TGLSLHandle.DoDestroyHandle(var AHandle: Cardinal); begin if not vContextActivationFailureOccurred then begin gl.ClearError; gl.DeleteObject(AHandle); gl.CheckError; end; end; function TGLSLHandle.InfoLog: string; var maxLength: Integer; log: AnsiString; begin maxLength := 0; gl.GetObjectParameteriv(GetHandle, GL_OBJECT_INFO_LOG_LENGTH_ARB, @maxLength); SetLength(log, maxLength); if maxLength > 0 then begin gl.GetInfoLog(GetHandle, maxLength, @maxLength, @log[1]); SetLength(log, maxLength); end; Result := string(log); end; class function TGLSLHandle.IsSupported: Boolean; begin Result := gl.ARB_shader_objects; end; // ------------------ // ------------------ TGLShaderHandle ------------------ // ------------------ function TGLShaderHandle.DoAllocateHandle: Cardinal; begin Result := gl.CreateShader(FShaderType) end; class function TGLShaderHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsShader(ID); end; procedure TGLShaderHandle.ShaderSource(const source: AnsiString); var p: PAnsiChar; begin p := PAnsiChar(AnsiString(source)); gl.ShaderSource(GetHandle, 1, @p, nil); end; function TGLShaderHandle.CompileShader: Boolean; var compiled: Integer; glH: Cardinal; begin glH := GetHandle; gl.CompileShader(glH); compiled := 0; gl.GetShaderiv(glH, GL_COMPILE_STATUS, @compiled); Result := (compiled <> 0); end; // ------------------ // ------------------ TGLVertexShaderHandle ------------------ // ------------------ constructor TGLVertexShaderHandle.Create; begin FShaderType := GL_VERTEX_SHADER_ARB; inherited; end; class function TGLVertexShaderHandle.IsSupported: Boolean; begin Result := gl.ARB_vertex_shader; end; // ------------------ // ------------------ TGLGeometryShaderHandle ------------------ // ------------------ constructor TGLGeometryShaderHandle.Create; begin FShaderType := GL_GEOMETRY_SHADER_EXT; inherited; end; class function TGLGeometryShaderHandle.IsSupported: Boolean; begin Result := gl.EXT_geometry_shader4; end; // ------------------ // ------------------ TGLFragmentShaderHandle ------------------ // ------------------ constructor TGLFragmentShaderHandle.Create; begin FShaderType := GL_FRAGMENT_SHADER_ARB; inherited; end; class function TGLFragmentShaderHandle.IsSupported: Boolean; begin Result := gl.ARB_fragment_shader; end; // ------------------ // ------------------ TGLTessControlShaderHandle ------------------ // ------------------ constructor TGLTessControlShaderHandle.Create; begin FShaderType := GL_TESS_CONTROL_SHADER; inherited; end; class function TGLTessControlShaderHandle.IsSupported: Boolean; begin Result := gl.ARB_tessellation_shader; end; // ------------------ // ------------------ TGLTessEvaluationShaderHandle ------------------ // ------------------ constructor TGLTessEvaluationShaderHandle.Create; begin FShaderType := GL_TESS_EVALUATION_SHADER; inherited; end; class function TGLTessEvaluationShaderHandle.IsSupported: Boolean; begin Result := gl.ARB_tessellation_shader; end; // ------------------ // ------------------ TGLProgramHandle ------------------ // ------------------ function TGLProgramHandle.DoAllocateHandle: Cardinal; begin Result := gl.CreateProgram(); end; class function TGLProgramHandle.IsValid(const ID: Cardinal): Boolean; begin Result := gl.IsProgram(ID); end; procedure TGLProgramHandle.AddShader(ShaderType: TGLShaderHandleClass; const ShaderSource: string; treatWarningsAsErrors: Boolean = False); var shader: TGLShaderHandle; begin shader := ShaderType.CreateAndAllocate; try if shader.Handle = 0 then raise EGLShader.Create('Couldn''t allocate ' + ShaderType.ClassName); shader.ShaderSource(AnsiString(ShaderSource)); if (not shader.CompileShader) or (treatWarningsAsErrors and (Pos('warning', LowerCase(shader.InfoLog)) > 0)) then raise EGLShader.Create(FName + ' (' + shader.ClassName + '): '#13#10 + shader.InfoLog); AttachObject(shader); finally shader.Free; end; gl.CheckError; end; procedure TGLProgramHandle.AttachObject(shader: TGLShaderHandle); begin gl.AttachShader(GetHandle, shader.Handle); end; procedure TGLProgramHandle.DetachAllObject; var glH: Cardinal; I: Integer; Count: TGLsizei; buffer: array [0 .. 255] of Cardinal; begin glH := GetHandle; if glH > 0 then begin gl.GetAttachedShaders(glH, Length(buffer), @Count, @buffer[0]); Count := MinInteger(Count, Length(buffer)); for I := 0 to Count - 1 do gl.DetachShader(glH, buffer[I]); NotifyChangesOfData; end; end; procedure TGLProgramHandle.BindAttribLocation(index: Integer; const aName: string); begin gl.BindAttribLocation(GetHandle, index, PAnsiChar(AnsiString(aName))); end; procedure TGLProgramHandle.BindFragDataLocation(index: Integer; const aName: string); begin gl.BindFragDataLocation(GetHandle, index, PAnsiChar(AnsiString(name))); end; function TGLProgramHandle.LinkProgram: Boolean; var Status: Integer; glH: Cardinal; begin glH := GetHandle; gl.LinkProgram(glH); Status := 0; gl.GetProgramiv(glH, GL_LINK_STATUS, @Status); Result := (Status <> 0); end; function TGLProgramHandle.ValidateProgram: Boolean; var validated: Integer; h: Cardinal; begin h := GetHandle; gl.ValidateProgram(h); validated := 0; gl.GetProgramiv(h, GL_VALIDATE_STATUS, @validated); Result := (validated <> 0); end; function TGLProgramHandle.GetAttribLocation(const aName: string): Integer; begin Result := gl.GetAttribLocation(GetHandle, PAnsiChar(AnsiString(aName))); Assert(Result >= 0, Format(strUnknownParam, ['attrib', aName, Name])); end; function TGLProgramHandle.GetUniformLocation(const aName: string): Integer; begin Result := gl.GetUniformLocation(GetHandle, PAnsiChar(AnsiString(aName))); Assert(Result >= 0, Format(strUnknownParam, ['uniform', aName, Name])); end; function TGLProgramHandle.GetVaryingLocation(const aName: string): Integer; begin Result := gl.GetVaryingLocation(GetHandle, PAnsiChar(AnsiString(aName))); Assert(Result >= 0, Format(strUnknownParam, ['varying', aName, Name])); end; procedure TGLProgramHandle.AddActiveVarying(const aName: string); begin gl.ActiveVarying(GetHandle, PAnsiChar(AnsiString(aName))); end; procedure TGLProgramHandle.UseProgramObject; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.CurrentProgram := Handle; end; procedure TGLProgramHandle.EndUseProgramObject; begin Assert(vCurrentGLContext <> nil); vCurrentGLContext.GLStates.CurrentProgram := 0; end; function TGLProgramHandle.GetUniform1i(const index: string): Integer; begin gl.GetUniformiv(GetHandle, GetUniformLocation(index), @Result); end; function TGLProgramHandle.GetUniform2i(const index: string): TVector2i; begin gl.GetUniformiv(GetHandle, GetUniformLocation(index), @Result); end; function TGLProgramHandle.GetUniform3i(const index: string): TVector3i; begin gl.GetUniformiv(GetHandle, GetUniformLocation(index), @Result); end; function TGLProgramHandle.GetUniform4i(const index: string): TVector4i; begin gl.GetUniformiv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniform1f(const index: string; val: Single); begin gl.Uniform1f(GetUniformLocation(index), val); end; function TGLProgramHandle.GetUniform1f(const index: string): Single; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniform1i(const index: string; val: Integer); begin gl.Uniform1i(GetUniformLocation(index), val); end; procedure TGLProgramHandle.SetUniform2i(const index: string; const Value: TVector2i); begin gl.Uniform2i(GetUniformLocation(index), Value.X, Value.Y); end; procedure TGLProgramHandle.SetUniform3i(const index: string; const Value: TVector3i); begin gl.Uniform3i(GetUniformLocation(index), Value.X, Value.Y, Value.Z); end; procedure TGLProgramHandle.SetUniform4i(const index: string; const Value: TVector4i); begin gl.Uniform4i(GetUniformLocation(index), Value.X, Value.Y, Value.Z, Value.W); end; function TGLProgramHandle.GetUniform2f(const index: string): TVector2f; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniform2f(const index: string; const val: TVector2f); begin gl.Uniform2f(GetUniformLocation(index), val.X, val.Y); end; function TGLProgramHandle.GetUniform3f(const index: string): TAffineVector; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniform3f(const index: string; const val: TAffineVector); begin gl.Uniform3f(GetUniformLocation(index), val.X, val.Y, val.Z); end; function TGLProgramHandle.GetUniform4f(const index: string): TGLVector; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniform4f(const index: string; const val: TGLVector); begin gl.Uniform4f(GetUniformLocation(index), val.X, val.Y, val.Z, val.W); end; function TGLProgramHandle.GetUniformMatrix2fv(const index: string): TMatrix2f; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniformMatrix2fv(const index: string; const val: TMatrix2f); begin gl.UniformMatrix2fv(GetUniformLocation(index), 1, False, @val); end; function TGLProgramHandle.GetUniformMatrix3fv(const index: string): TMatrix3f; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniformMatrix3fv(const index: string; const val: TMatrix3f); begin gl.UniformMatrix3fv(GetUniformLocation(index), 1, False, @val); end; function TGLProgramHandle.GetUniformMatrix4fv(const index: string): TGLMatrix; begin gl.GetUniformfv(GetHandle, GetUniformLocation(index), @Result); end; procedure TGLProgramHandle.SetUniformMatrix4fv(const index: string; const val: TGLMatrix); begin gl.UniformMatrix4fv(GetUniformLocation(index), 1, False, @val); end; procedure TGLProgramHandle.SetUniformf(const index: string; const val: Single); begin SetUniform1f(index, val); end; procedure TGLProgramHandle.SetUniformf(const index: string; const val: TVector2f); begin SetUniform2f(index, val); end; procedure TGLProgramHandle.SetUniformf(const index: string; const val: TVector3f); begin SetUniform3f(index, val); end; procedure TGLProgramHandle.SetUniformf(const index: string; const val: TVector4f); begin SetUniform4f(index, val); end; procedure TGLProgramHandle.SetUniformi(const index: string; const val: Integer); begin SetUniform1f(index, val); end; procedure TGLProgramHandle.SetUniformi(const index: string; const val: TVector2i); begin SetUniform2i(index, val); end; procedure TGLProgramHandle.SetUniformi(const index: string; const val: TVector3i); begin SetUniform3i(index, val); end; procedure TGLProgramHandle.SetUniformi(const index: string; const val: TVector4i); begin SetUniform4i(index, val); end; function TGLProgramHandle.GetUniformTextureHandle(const index: string; const TextureIndex: Integer; const TextureTarget: TGLTextureTarget): Cardinal; begin Result := GetUniform1i(index); end; procedure TGLProgramHandle.SetUniformTextureHandle(const index: string; const TextureIndex: Integer; const TextureTarget: TGLTextureTarget; const Value: Cardinal); begin vCurrentGLContext.GLStates.TextureBinding[0, TextureTarget] := Value; SetUniform1i(index, TextureIndex); end; procedure TGLProgramHandle.SetUniformBuffer(const index: string; Value: TGLUniformBufferHandle); begin gl.UniformBuffer(Handle, GetUniformLocation(index), Value.Handle); end; function TGLProgramHandle.GetUniformBufferSize(const aName: string): Integer; begin Result := gl.GetUniformBufferSize(Handle, GetUniformLocation(aName)); end; function TGLProgramHandle.GetUniformOffset(const aName: string): PGLInt; begin Result := gl.GetUniformOffset(Handle, GetUniformLocation(aName)); end; function TGLProgramHandle.GetUniformBlockIndex(const aName: string): Integer; begin Result := gl.GetUniformBlockIndex(Handle, PAnsiChar(AnsiString(aName))); Assert(Result >= 0, Format(strUnknownParam, ['uniform block', aName, Name])); end; constructor TGLProgramHandle.Create; begin inherited Create; FName := 'DefaultShaderName'; end; // ------------------ // ------------------ TGLContextManager ------------------ // ------------------ {$IFDEF USE_SERVICE_CONTEXT} procedure OnApplicationInitialize; begin InitProc := OldInitProc; Application.Initialize; GLContextManager.CreateServiceContext; end; {$ENDIF} constructor TGLContextManager.Create; begin inherited Create; {$IFNDEF USE_MULTITHREAD} FHandles := TList.Create; {$ELSE} FHandles := TThreadList.Create; {$ENDIF USE_MULTITHREAD} FList := TThreadList.Create; end; destructor TGLContextManager.Destroy; begin FHandles.Free; FList.Free; inherited Destroy; end; function TGLContextManager.CreateContext(AClass: TGLContextClass): TGLContext; begin if Assigned(AClass) then begin Result := AClass.Create; Result.FManager := Self; end else if Assigned(vContextClasses) and (vContextClasses.Count > 0) then begin Result := TGLContextClass(vContextClasses.Last).Create; Result.FManager := Self; end else Result := nil; end; {$IFDEF USE_SERVICE_CONTEXT} procedure TGLContextManager.CreateServiceContext; begin FServiceContext := CreateContext; FThreadTask := TServiceContextTaskList.Create; FServiceStarter := TFinishTaskEvent.Create; FThread := TServiceContextThread.Create; AddTaskForServiceContext(TServiceContextThread(FThread).DoCreateServiceContext); end; procedure TGLContextManager.QueueTaskDepleted; var TaskRec: TServiceContextTask; I: Integer; nowTime: Double; begin with FThreadTask.LockList do try for I := 0 to Count - 1 do begin TaskRec := Items[I]; if Assigned(TaskRec.Task) then begin FThreadTask.UnlockList; // Task queue not empty FServiceStarter.SetEvent; exit; end; end; finally FThreadTask.UnlockList; end; FServiceStarter.ResetEvent; FThreadTask.Clear; nowTime := Now; with TServiceContextThread(FThread) do if (nowTime - FLastTaskStartTime > 30000) and not FReported then begin FReported := True; GLSLogger.LogInfo('Service context queue task depleted'); end; end; {$ENDIF USE_SERVICE_CONTEXT} procedure TGLContextManager.Lock; begin FList.LockList; end; procedure TGLContextManager.NotifyPreparationNeed; var I: Integer; LList: TList; begin LList := FList.LockList; try for I := LList.Count - 1 downto 0 do TGLContext(LList[I]).FIsPraparationNeed := True; finally FList.UnlockList; end; end; procedure TGLContextManager.UnLock; begin FList.UnlockList; end; function TGLContextManager.ContextCount: Integer; begin // try..finally just a waste of CPU here, if Count fails, the list is amok, // and so is the lock... Result := FList.LockList.Count; FList.UnlockList; end; procedure TGLContextManager.RegisterContext(aContext: TGLContext); begin with FList.LockList do try if IndexOf(aContext) >= 0 then raise EGLContext.Create(strInvalidContextRegistration) else Add(aContext); finally FList.UnlockList; end; end; procedure TGLContextManager.UnRegisterContext(aContext: TGLContext); begin with FList.LockList do try if IndexOf(aContext) < 0 then raise EGLContext.Create(strInvalidContextRegistration) else Remove(aContext); finally FList.UnlockList; end; end; procedure TGLContextManager.ContextCreatedBy(aContext: TGLContext); begin Lock; try Inc(FCreatedRCCount); finally UnLock; end; end; procedure TGLContextManager.DestroyingContextBy(aContext: TGLContext); var cn: TGLContextNotification; begin Lock; try Dec(FCreatedRCCount); if FCreatedRCCount = 0 then begin // yes, slow and bulky, but allows for the triggered event to // cascade-remove notifications safely while Length(FNotifications) > 0 do begin cn := FNotifications[High(FNotifications)]; SetLength(FNotifications, Length(FNotifications) - 1); cn.Event(cn.obj); end; end; finally UnLock; end; end; procedure TGLContextManager.LastContextDestroyNotification(anObject: TObject; anEvent: TNotifyEvent); begin Lock; try SetLength(FNotifications, Length(FNotifications) + 1); with FNotifications[High(FNotifications)] do begin obj := anObject; Event := anEvent; end; finally UnLock; end; end; procedure TGLContextManager.RemoveNotification(anObject: TObject); var I: Integer; found: Boolean; begin Lock; try found := False; I := Low(FNotifications); while I <= High(FNotifications) do begin if FNotifications[I].obj = anObject then begin found := True; while I <= High(FNotifications) do begin FNotifications[I] := FNotifications[I + 1]; Inc(I); end; SetLength(FNotifications, Length(FNotifications) - 1); Break; end; Inc(I); end; if not found then raise EGLContext.Create(strInvalidNotificationRemoval); finally UnLock; end; end; procedure TGLContextManager.Terminate; begin FTerminated := True; {$IFDEF USE_SERVICE_CONTEXT} // Sevice context may not be created becouse Application.Initialize not happened if Assigned(FServiceContext) then begin CheckSynchronize; FThread.Terminate; FServiceStarter.SetEvent; FThread.WaitFor; FThread.Destroy; GLSLogger.LogDebug('Service thread destroyed'); FServiceStarter.Destroy; FThreadTask.Destroy; end; {$ENDIF} if ContextCount = 0 then begin GLContextManager := nil; Free; end; end; procedure TGLContextManager.DestroyAllHandles; var I: Integer; begin with FList.LockList do try for I := Count - 1 downto 0 do TGLContext(Items[I]).DestroyAllHandles; finally FList.UnlockList; end; end; {$IFDEF USE_SERVICE_CONTEXT} constructor TServiceContextThread.Create; begin FWindow := TForm.CreateNew(nil); FWindow.Hide; FWindow.Position := poScreenCenter; FWindow.width := 1; FWindow.height := 1; FWindow.BorderStyle := bsNone; FWindow.FormStyle := fsStayOnTop; FWindow.Color := 0; vServiceWindow := FWindow; {$IFDEF MSWINDOWS} FDC := GetDC(FWindow.Handle); {$ENDIF} {$IFDEF LINUX} FDC := FWindow.Handle; {$ENDIF} inherited Create(False); end; destructor TServiceContextThread.Destroy; begin ReleaseDC(FWindow.Handle, FDC); FWindow.Free; inherited; end; procedure TServiceContextThread.DoCreateServiceContext; stdcall; procedure Fail; begin GLSLogger.LogError(Format('%s: can''t initialize rendering context', [ClassName])); FWindow.Destroy; vServiceWindow := nil; end; begin try GLContextManager.ServiceContext.Acceleration := chaHardware; GLContextManager.ServiceContext.CreateMemoryContext(FDC, 1, 1, 1); except on EGLContext do begin Fail; exit; end; on EPBuffer do begin GLSLogger.LogWarning(Format('%s: can''t initialize memory rendering context. Try initialize common context.', [ClassName])); try GLContextManager.ServiceContext.CreateContext(FDC); except Fail; exit; end; end; end; GLSLogger.LogNotice('Service context successfuly initialized'); GLContextManager.ServiceContext.Activate; FWindow.Hide; vServiceWindow := nil; end; procedure TServiceContextThread.Execute; var TaskRec: TServiceContextTask; procedure NextTask; const NullTask: TServiceContextTask = (Task: nil; Event: nil); var I: Integer; begin TaskRec.Task := nil; with GLContextManager.FThreadTask.LockList do try for I := 0 to Count - 1 do begin TaskRec := Items[I]; if Assigned(TaskRec.Task) then begin Items[I] := NullTask; Break; end; end; finally GLContextManager.FThreadTask.UnlockList; end; end; begin with GLContextManager do begin vMainThread := False; GLSLogger.LogNotice('Service thread started'); Sleep(100); try while not Terminated do begin NextTask; if Assigned(TaskRec.Task) then begin with GLContextManager.ServiceContext do begin if IsValid then Activate; try TaskRec.Task; except GLSLogger.LogError('Service thread task raised exception'); end; if IsValid then Deactivate; if Assigned(TaskRec.Event) then TaskRec.Event.SetEvent; end; end else Synchronize(GLContextManager.QueueTaskDepleted); ServiceStarter.WaitFor(30000); end; finally ServiceContext.Destroy; FServiceContext := nil; GLSLogger.LogNotice('Service thread finished'); end; end; end; procedure AddTaskForServiceContext(ATask: TTaskProcedure; FinishEvent: TFinishTaskEvent = nil); var TaskRec: TServiceContextTask; rEvent: TFinishTaskEvent; begin if vMainThread then begin rEvent := nil; if Assigned(GLContextManager.ServiceContext) and Assigned(ATask) then begin CheckSynchronize; with GLContextManager.FThreadTask.LockList do try TaskRec.Task := ATask; if FinishEvent = nil then begin // Synchronous call rEvent := TFinishTaskEvent.Create; TaskRec.Event := rEvent; end else // Asynchronous call TaskRec.Event := FinishEvent; Add(TaskRec); with TServiceContextThread(GLContextManager.FThread) do begin FLastTaskStartTime := Now; FReported := False; end; finally GLContextManager.FThreadTask.UnlockList; end; GLContextManager.ServiceStarter.SetEvent; end; // Wait task finishing if Assigned(rEvent) then begin rEvent.WaitFor(INFINITE); rEvent.Destroy; CheckSynchronize; end; end else begin // Direct task execution in service thread try ATask; except GLSLogger.LogError('Service thread task raised exception'); end; if Assigned(FinishEvent) then FinishEvent.SetEvent; end; end; {$ENDIF USE_SERVICE_CONTEXT} constructor TFinishTaskEvent.Create; begin inherited Create(nil, True, False, ''); end; // ------------------------------------------------------------------ initialization // ------------------------------------------------------------------ vMainThread := True; {$IFDEF USE_SERVICE_CONTEXT} OldInitProc := InitProc; InitProc := @OnApplicationInitialize; {$ENDIF USE_SERVICE_CONTEXT} GLContextManager := TGLContextManager.Create; GLwithoutContext := TGLExtensionsAndEntryPoints.Create; GLwithoutContext.Close; // vLocalGL := @GL; finalization GLContextManager.Terminate; vContextClasses.Free; vContextClasses := nil; GLwithoutContext.Free; GLwithoutContext := nil; end.