<<>> <> <> <> <> <<>> DIRECTORY Atom, ImagerSample, Process, Rope, SafeStorage, SF, UnixErrno, UnixShm0, UnixTypes, VMChunks, Xl, XlAccess, XlDetails, XlExtensions, XlPrivate, XlPrivateErrorHandling, XlPrivateResources, XlShmMonitor, XlShmPixmaps, XlShmPixmapsExtras; XlShmPixmapsImpl: CEDAR MONITOR LOCKS c USING c: Xl.Connection IMPORTS Atom, ImagerSample, Process, Rope, SafeStorage, SF, UnixErrno, UnixShm0, VMChunks, Xl, XlAccess, XlDetails, XlExtensions, XlPrivate, XlPrivateErrorHandling, XlPrivateResources EXPORTS XlShmPixmaps, XlShmMonitor, XlShmPixmapsExtras SHARES Xl, XlPrivate = BEGIN OPEN XlShmPixmaps; <> <> <> <> ROPE: TYPE = Rope.ROPE; shmExtensionKey: ATOM = Atom.MakeAtom["MIT-SHM"]; shmQueryVersionMinor: BYTE = 0; shmQueryAttachMinor: BYTE = 1; shmQueryDetachMinor: BYTE = 2; shmQueryPutImageMinor: BYTE = 3; shmQueryGetImageMinor: BYTE = 4; shmQueryCreatePixmapMinor: BYTE = 5; neverUseThis: BOOL ¬ FALSE; DebugSetNeverUseThis: PROC [b: BOOL] = {neverUseThis ¬ b}; GetShmConnectionData: PROC [c: Xl.Connection] RETURNS [d: REF ShmConnectionData] = INLINE { d ¬ NARROW [Xl.GetConnectionPropAndInit[c, privateKey, InitShmExtension]]; }; privateKey: REF INT ~ NEW[INT]; InitShmExtension: Xl.InitializeProcType = { <<--For this connection>> shmd: REF ShmConnectionData ¬ NEW[ShmConnectionData]; IF ~Disabled1[c] THEN { shmd.ex ¬ XlExtensions.StartExtension[c, shmExtensionKey]; IF shmd.ex#NIL AND ~Disabled2[c] THEN { shmd.supportAndLocal ¬ TRUE; shmd.sv ¬ UncachedSHMQueryVersion[c, shmd ! ANY => {shmd.supportAndLocal ¬ FALSE; CONTINUE}]; shmd.supportLocalAndPixmaps ¬ shmd.supportAndLocal AND shmd.sv.pixmaps; IF ~shmd.sv.hasExtension THEN {shmd­ ¬ []}; --inconsistent }; }; RETURN [shmd] }; GetShmConnectionDataAndTest: PROC [c: Xl.Connection] RETURNS [shmd: REF ShmConnectionData] = { shmd ¬ GetShmConnectionData[c]; IF shmd.ex=NIL THEN { --extension is not supported err: REF Xl.EventRep.errorNotify ¬ NEW[Xl.EventRep.errorNotify]; err.connection ¬ c; ERROR Xl.XError[err]; }; }; XShmID: TYPE ~ Xl.ID; <> SHMAttach: PUBLIC PROC [c: Xl.Connection, shmInfo: ShmInfoRec, details: Xl.Details ¬ NIL] RETURNS [xShmID: XShmID ¬ 0] = { shmd: REF ShmConnectionData ~ GetShmConnectionDataAndTest[c]; action: PROC [c: Xl.Connection] = { xShmID ¬ XlPrivateResources.NewResourceID[c]; XlPrivate.BInit[c, shmd.ex.majorOpcode, shmQueryAttachMinor, 4]; XlPrivate.BPut32[c, xShmID]; --X id XlPrivate.BPut32[c, shmInfo.shmId.val]; XlPrivate.BPut8[c, ORD[shmInfo.readonly]]; XlPrivate.BSkip[c, 3]; XlPrivate.FinishWithDetails[c, details]; }; XlPrivate.DoWithLocks[c, action, details]; }; SHMCreatePixmap: PUBLIC PROC [c: Xl.Connection, drawable: Xl.Drawable, xShmID: XShmID, offset: CARD32, size: Xl.Size, depth: BYTE, details: Xl.Details] RETURNS [p: Xl.Pixmap ¬ Xl.nullPixmap] = { <<--assumed memory layout of pixmap is not documented>> <<--therefore: nice numbers please>> shmd: REF ShmConnectionData ~ GetShmConnectionDataAndTest[c]; action: PROC [c: Xl.Connection] = { p ¬ [[XlPrivateResources.NewResourceID[c]]]; XlPrivate.BInit[c, shmd.ex.majorOpcode, shmQueryCreatePixmapMinor, 7]; XlPrivate.BPutPixmap[c, p]; XlPrivate.BPutDrawable[c, drawable]; XlPrivate.BPutSize[c, size]; XlPrivate.BPut8[c, depth]; XlPrivate.BSkip[c, 3]; XlPrivate.BPut32[c, xShmID]; XlPrivate.BPut32[c, offset]; XlPrivate.FinishWithDetails[c, details]; }; IF size.width MOD (32/depth) # 0 THEN --XXX Warning: machine dependency 32 introduced XlPrivateErrorHandling.RaiseClientError[c, $widthOfShmPixmap]; --size not reasonable XlPrivate.DoWithLocks[c, action, details]; }; SHMDetach: PUBLIC PROC [c: Xl.Connection, xShmID: XShmID, details: Xl.Details] = { action: PROC [c: Xl.Connection] = { XlPrivate.BInit[c, shmd.ex.majorOpcode, shmQueryDetachMinor, 2]; XlPrivate.BPut32[c, xShmID]; XlPrivate.FinishWithDetails[c, details]; }; shmd: REF ShmConnectionData ~ GetShmConnectionDataAndTest[c]; XlPrivate.DoWithLocks[c, action, details]; }; ShmConnectionData: TYPE ~ PRIVATE RECORD [ <<--property of connection>> ex: XlExtensions.Extension, --NIL if extension not supported sv: SHMVersion ¬ [hasExtension: FALSE, major: 0, minor: 0, pixmaps: FALSE], supportAndLocal: BOOL ¬ FALSE, supportLocalAndPixmaps: BOOL ¬ FALSE ]; UncachedSHMQueryVersion: PROC [c: Xl.Connection, shmd: REF ShmConnectionData] RETURNS [sv: SHMVersion ¬ [hasExtension: FALSE, major: 0, minor: 0, pixmaps: FALSE]] = { reply: XlPrivate.Reply; action: PROC [c: Xl.Connection] = { XlPrivate.BInit[c, shmd.ex.majorOpcode, shmQueryVersionMinor, 1]; reply ¬ XlPrivate.FinishWithReply[c]; }; IF shmd.ex#NIL THEN { XlPrivate.DoWithLocks[c, action, NIL]; XlPrivate.CheckReply[reply]; sv.pixmaps ¬ XlPrivate.ERead8[reply]#0; XlPrivate.Skip[reply, 6]; sv.major ¬ XlPrivate.ERead16[reply]; sv.minor ¬ XlPrivate.ERead16[reply]; <> <> sv.hasExtension ¬ TRUE; }; }; SHMQueryVersion: PUBLIC PROC [c: Xl.Connection] RETURNS [SHMVersion] = { shmd: REF ShmConnectionData ~ GetShmConnectionData[c]; RETURN [shmd.sv]; }; SHMVersion: TYPE ~ RECORD [hasExtension: BOOL, major, minor: INT, pixmaps: BOOL]; <> <> <<};>> <<>> <> <> <<};>> <<------------------------------>> ShmInfoRec: TYPE = RECORD [ shmId: UnixShm0.SharedMemoryIdentifier, addr: POINTER, --local address of shared memory segment readonly: BOOL ¬ FALSE ]; ShmAllocSegmentateSystemId: PROC [nbytes: INT, permissions: [0..512) ¬ UnixShm0.allPerms.val] RETURNS [shmId: UnixShm0.SharedMemoryIdentifier] = { <> shmId ¬ UnixShm0.ShmGet[key: UnixShm0.ipcPRIVATE, size: nbytes, shmflg: [UnixShm0.ipcCREAT.val+permissions]]; IF LOOPHOLE[shmId, INT] = -1 THEN SignalUnixError[]; }; ShmAllocSegmentateNew: PROC [nbytes: INT] RETURNS [info: ShmInfoRec] = { vmAddr: POINTER; i: INT; info.shmId ¬ ShmAllocSegmentateSystemId[nbytes]; vmAddr ¬ UnixShm0.VMReserve[nbytes]; --untraced IF vmAddr = NIL THEN ERROR; i ¬ UnixShm0.ShmAt[id: info.shmId, addr: vmAddr, flags: UnixShm0.noFlags]; IF i = -1 THEN SignalUnixError[]; info.addr ¬ LOOPHOLE[i]; IF info.addr # vmAddr THEN ERROR; }; SignalUnixError: PROC [] = { errno: UnixErrno.Errno ~ UnixErrno.GetErrno[]; UnixError[errno]; }; UnixError: ERROR [errno: UnixErrno.Errno] = CODE; <<------------------------------>> LinkedSegment: TYPE = RECORD [ domain: VMChunks.Domain ¬ NIL, shmInfo: ShmInfoRec, bytes: CARD, key: REF ¬ NIL, next: REF LinkedSegment ¬ NIL ]; rootSegment: REF LinkedSegment ¬ NIL; lastUnixErrno: UnixErrno.Errno ¬ ok; maxSegmentSize: CARD = 4*1024*1024; --oops, some kernels don't allow more then 1 meg, but for now this will simply fail. However we try defaultSegmentSize if ever possible. defaultSegmentSize: INT = 1024*1024; fakeConnection: Xl.Connection = NEW[Xl.ConnectionRep]; --delivers a MONITOR Next: PUBLIC <> PROC [segment: REF ¬ NIL] RETURNS [REF] = { WITH segment SELECT FROM ls: REF LinkedSegment => RETURN [ls.next]; ENDCASE => RETURN [rootSegment]; }; <<>> Info: PUBLIC <> PROC [segment: REF] RETURNS [addr: CARD, bytes: CARD, id: CARD] = { ls: REF LinkedSegment ~ NARROW[segment]; RETURN [LOOPHOLE[ls.shmInfo.addr], ls.bytes, LOOPHOLE[ls.shmInfo.shmId]]; }; <<>> PreAllocate: PUBLIC PROC [nbytes: CARD] = { nbytes ¬ MAX[nbytes, defaultSegmentSize]; nbytes ¬ MIN[nbytes, maxSegmentSize]; [] ¬ AllocateSegment[nbytes]; }; AllocateSegment: PROC [nbytes: CARD ¬ defaultSegmentSize] RETURNS [ls: REF LinkedSegment ¬ NIL] = { Link: ENTRY PROC [c: Xl.Connection<>, ls: REF LinkedSegment] = { ls.next ¬ rootSegment; rootSegment ¬ ls }; Alloc: PROC [nbytes: CARD] RETURNS [ls: REF LinkedSegment] = { ENABLE { UnixError => { <<--Don't worry about shared memory, it is optional>> lastUnixErrno ¬ errno; GOTO oops; }; UNCAUGHT => { GOTO oops; }; }; ls ¬ NEW[LinkedSegment]; ls.shmInfo ¬ ShmAllocSegmentateNew[nbytes]; ls.domain ¬ VMChunks.CreateDomain[LOOPHOLE[ls.shmInfo.addr], nbytes]; ls.bytes ¬ nbytes; ls.key ¬ NEW[INT]; EXITS oops => RETURN [NIL]; }; IF nbytes>maxSegmentSize THEN RETURN [NIL]; ls ¬ Alloc[nbytes]; IF ls#NIL THEN Link[fakeConnection, ls]; }; Block: TYPE = RECORD [ls: REF LinkedSegment, chunk: VMChunks.Chunk]; <> AllocateBlock: PROC [nbytes: CARD] RETURNS [REF Block ¬ NIL] = { ls: REF LinkedSegment ¬ rootSegment; nbytes ¬ nbytes+63/64*64; --chunkize to reduce fragmentation <<--linear search, starting in front may be simplistic, but the list is short (each segment is large)>> WHILE ls#NIL DO c: VMChunks.Chunk ¬ VMChunks.AllocateChunk[ls.domain, nbytes]; IF c#NIL THEN RETURN [NEW[Block ¬ [ls, c]]]; ls ¬ ls.next ENDLOOP; <<--try hard to reuse a segment, but don't garbage collect in start up code>> ls ¬ rootSegment; IF ls#NIL THEN { SafeStorage.ReclaimCollectibleObjects[]; Process.Yield[]; --give the finalizations a chance WHILE ls#NIL DO c: VMChunks.Chunk ¬ VMChunks.AllocateChunk[ls.domain, nbytes]; IF c#NIL THEN RETURN [NEW[Block ¬ [ls, c]]]; ls ¬ ls.next ENDLOOP; }; <<--prevent small segments>> IF nbytes> <<--We dont use ImagerSample.BitsForSamples because we want alignment of the server, not the host.>> <<--For sparc use double words (8 bytes).>> SELECT bitsPerSample FROM 1 => w ¬ (w+63) / 64 * 64; --8 8 => w ¬ (w+ 7) / 8 * 8; --8 4 => w ¬ (w+15) / 16 * 16; --8 2 => w ¬ (w+31) / 32 * 32; --8 24 => w ¬ (w+ 3) / 4 * 4; --align for egret 32 => w ¬ (w+ 1) / 2 * 2; --8 16 => w ¬ (w+ 3) / 4 * 4; --8 ENDCASE => RETURN [NIL]; -- don't support this bitsPerSample box.max.f ¬ INT[box.min.f] + LOOPHOLE[w, INT]; END; nbytes ¬ (w*bitsPerSample)/8*h; IF nbytes<=maxSegmentSize THEN block ¬ AllocateBlock[nbytes]; IF block=NIL THEN RETURN [NIL]; --not enough space addr ¬ VMChunks.AddressOfChunk[block.chunk]; TRUSTED { sm ¬ ImagerSample.UnsafeNewSampleMap[box: box, bitsPerSample: bitsPerSample, bitsPerLine: w*bitsPerSample, base: [word: LOOPHOLE[addr], bit: 0], ref: block, words: nbytes / BYTES[WORD]]; }; <> }; Disabled1: PROC [c: Xl.Connection] RETURNS [BOOL] = { <<--Many protocol translaters faithfully translate a servers claim to support shared memory; even if they use a remote server... This supports one test against that.>> <<--First easy tests without actually accessing server>> IF c=NIL THEN RETURN [TRUE]; RETURN [ Xl.GetConnectionProp[c, $PreventSharedMemory]#NIL ] }; ServerHostFromConvention: PROC [c: Xl.Connection] RETURNS [Rope.ROPE ¬ NIL] = { ENABLE ANY => GOTO Oops; serverHostAtom: Xl.XAtom ~ Xl.MakeAtom[c, "PARC_ServerHost"]; prr: Xl.PropertyReturnRec ~ Xl.GetProperty[c: c, w: Xl.FirstRoot[c], property: serverHostAtom, supposedFormat: 8]; WITH prr.value SELECT FROM r: Rope.ROPE => RETURN [r]; ENDCASE => {} EXITS Oops => {} }; Disabled2: PROC [c: Xl.Connection] RETURNS [BOOL ¬ FALSE] = { <<--Slightly slower and harder tests. >> <<--Tests whether server is local at all.>> <<--Test whether server knows its name and whether it matches with the host.>> name: Rope.ROPE; isLocalhost: BOOL; IF Disabled1[c] THEN RETURN [TRUE]; name ¬ Xl.ServerName[c]; isLocalhost ¬ XlAccess.IsLocalHost[Xl.ServerName[c]]; IF ~isLocalhost THEN RETURN [TRUE]; name ¬ ServerHostFromConvention[c]; isLocalhost ¬ Rope.IsEmpty[name] OR XlAccess.IsLocalHost[name]; IF ~isLocalhost THEN RETURN [TRUE]; }; TestWorking: PROC [c: Xl.Connection] RETURNS [ok: BOOL] = { <> <> someXSR: REF LinkedSegment ¬ rootSegment; shmd: REF ShmConnectionData ~ GetShmConnectionData[c]; IF shmd=NIL OR ~shmd.supportAndLocal OR someXSR=NIL THEN RETURN [FALSE]; [] ¬ GetXShmId[c, someXSR ! Xl.XError => {shmd.supportAndLocal ¬ FALSE; CONTINUE}]; IF ~shmd.supportAndLocal THEN { Xl.PutConnectionProp[c, $PreventSharedMemory, $PreventSharedMemory] }; RETURN [shmd.supportAndLocal]; }; ConnectionSupportsThis: PUBLIC PROC [c: Xl.Connection] RETURNS [BOOL] = { IF neverUseThis THEN RETURN [FALSE]; IF c=NIL THEN RETURN [~neverUseThis]; IF Disabled1[c] THEN RETURN [FALSE]; RETURN [TestWorking[c]]; }; ConnectionSupportsPixmaps: PUBLIC PROC [c: Xl.Connection] RETURNS [BOOL ¬ FALSE] = { IF ~neverUseThis THEN { shmd: REF ShmConnectionData ¬ GetShmConnectionData[c]; IF shmd.supportLocalAndPixmaps THEN RETURN [TestWorking[c]]; }; }; SampleMapSupportsThis: PUBLIC PROC [sm: ImagerSample.SampleMap] RETURNS [BOOL] = { IF neverUseThis THEN RETURN [FALSE]; RETURN [SampleMapPiece[sm]#NIL] }; SampleMapPiece: PROC [sm: ImagerSample.SampleMap] RETURNS [REF Block ¬ NIL] = { WITH sm SELECT FROM rsm: ImagerSample.RasterSampleMap => WITH ImagerSample.GetRef[rsm] SELECT FROM p: REF Block => RETURN [p]; ENDCASE => RETURN [NIL]; ENDCASE => {}; }; GetXShmId: PROC [c: Xl.Connection, ls: REF LinkedSegment] RETURNS [xshmid: XShmID] = { GetXShmInit: Xl.InitializeProcType = { refXId: REF XShmID ¬ NEW[XShmID]; refXId­ ¬ SHMAttach[c, ls.shmInfo, XlDetails.synchronousErrors ! Xl.XError => { shmd: REF ShmConnectionData ~ GetShmConnectionData[c]; IF shmd#NIL THEN { shmd.supportAndLocal ¬ FALSE; shmd.supportLocalAndPixmaps ¬ FALSE; }; refXId­ ¬ 0; CONTINUE }]; RETURN [refXId] }; refXId: REF XShmID ¬ NARROW[Xl.GetConnectionPropAndInit[c, ls.key, GetXShmInit]]; RETURN [refXId­] }; UnsafeCreatePixmap: PUBLIC PROC [c: Xl.Connection, drawable: Xl.Drawable ¬ Xl.nullDrawable, sm: ImagerSample.RasterSampleMap] RETURNS [p: Xl.Pixmap] = { <> block: REF Block ¬ SampleMapPiece[sm]; sz: SF.Vec ¬ ImagerSample.GetSize[sm]; bps: NAT ¬ ImagerSample.GetBitsPerSample[sm]; xshmid: XShmID; offset: CARD32; IF ~ConnectionSupportsThis[c] THEN ERROR; IF block=NIL THEN ERROR; --sm not created with this module offset ¬ LOOPHOLE[ImagerSample.GetBase[sm].word, CARD32] - LOOPHOLE[block.ls.shmInfo.addr, CARD32]; xshmid ¬ GetXShmId[c, block.ls]; p ¬ SHMCreatePixmap[c: c, drawable: drawable, xShmID: xshmid, offset: offset, size: [sz.f, sz.s], depth: bps, details: XlDetails.synchronousErrors] }; ProcessExtension: XlExtensions.ProcessExtensionEventProc = { }; PreAllocate[defaultSegmentSize]; XlExtensions.DefineExtensionClass[key: shmExtensionKey, processEvents: ProcessExtension]; TRUSTED { [] ¬ UnixShm0.RegisterUNTHREADEDTerminationCleanupProc[UNTHREADEDBeforeQuitWorld]; }; END.