
<html>

<head>

<style>

.hmmessage P

{

margin:0px;

padding:0px

}

body.hmmessage

{

FONT-SIZE: 10pt;

FONT-FAMILY:Tahoma

}

</style>

</head>

<body class='hmmessage'>Um, so the file exists..does it get compiled? Did you look at the m3makefiles?<BR>

I skimmed the m3makefiles. I have not tried building PM3 myself.<BR>

 <BR>

 - Jay<BR><BR>


<HR id=stopSpelling>

<BR>

> To: jayk123@hotmail.com<BR>> CC: m3devel@elegosoft.com<BR>> Subject: Re: [M3devel] nt386gnu threads? <BR>> Date: Mon, 28 Jan 2008 04:04:50 -0800<BR>> From: mika@async.caltech.edu<BR>> <BR>> I am almost certain it uses Win32 threads. Attached: ThreadWin32.m3<BR>> from PM3-Klagenfurt<BR>> <BR>> Mika<BR>> <BR>> Jay writes:<BR>> >--_ddef1601-2afe-4ff4-9567-11d7fc5d354a_<BR>> >Content-Type: text/plain; charset="iso-8859-1"<BR>> >Content-Transfer-Encoding: quoted-printable<BR>> ><BR>> >Can anyone confirm my read that PM3's NT386GNU used user/vtalarm threads?<BR>> ....<BR>> <BR>> <BR>> (* Copyright (C) 1994, Digital Equipment Corporation *)<BR>> (* All rights reserved. *)<BR>> (* See the file COPYRIGHT for a full description. *)<BR>> (* *)<BR>> (* portions Copyright 1996, Critical Mass, Inc. *)<BR>> (* *)<BR>> (* Last modified on Fri Apr 26 10:21:56 PDT 1996 by heydon *)<BR>> (* modified on Thu Jun 15 09:06:37 PDT 1995 by kalsow *)<BR>> (* modified on Tue Oct 4 10:34:00 PDT 1994 by isard *)<BR>> (* modified on Tue May 4 10:20:03 PDT 1993 by mjordan *)<BR>> (* modified on Wed Apr 21 16:31:21 PDT 1993 by mcjones *)<BR>> (* modified on Fri Mar 26 15:04:39 PST 1993 by birrell *)<BR>> <BR>> UNSAFE MODULE ThreadWin32<BR>> EXPORTS Scheduler, Thread, ThreadF, RTThreadInit, RTHooks;<BR>> <BR>> IMPORT RTHeapRep, RTLinker, RTMisc, WinBase, WinDef, WinNT, ThreadContext;<BR>> IMPORT Word;<BR>> (*** IMPORT RTIO; ***)<BR>> <BR>> (*----------------------------------------- Exceptions, types and globals ---*)<BR>> <BR>> VAR<BR>> cm: WinBase.LPCRITICAL_SECTION;<BR>> (* Global lock for internals of Mutex and Condition *)<BR>> <BR>> default_stack: WinDef.DWORD := 16384;<BR>> <BR>> nextId: Id := 1;<BR>> <BR>> REVEAL<BR>> Mutex = BRANDED "MUTEX Win32-1.0" OBJECT<BR>> cs: WinBase.LPCRITICAL_SECTION := NIL;<BR>> held: BOOLEAN := FALSE;<BR>> (* LL = self.cs *)<BR>> (* Because critical sections are thread re-entrant *)<BR>> END;<BR>> <BR>> Condition = BRANDED "Thread.Condition Win32-1.0" OBJECT<BR>> waiters: T := NIL;<BR>> (* LL = cm *)<BR>> (* List of threads waiting on this CV. *)<BR>> END;<BR>> <BR>> T = BRANDED "Thread.T Win32-1.0" OBJECT<BR>> next, prev: T := NIL;<BR>> (* LL = threadMu; global doubly-linked, circular list of all threads *)<BR>> nextIdle: T := NIL;<BR>> (* LL = threadMu; global list of idle threads *)<BR>> handle: WinNT.HANDLE := NIL;<BR>> (* LL = threadMu; thread handle in Windows *)<BR>> stackbase: ADDRESS := NIL;<BR>> (* LL = threadMu; base of thread stack for use by GC *)<BR>> closure: Closure := NIL;<BR>> (* LL = threadMu *)<BR>> result: REFANY := NIL;<BR>> (* LL = threadMu; if not self.completed, used only by self;<BR>> if self.completed, read-only. *)<BR>> cond: Condition;<BR>> (* LL = threadMu; wait here to join, or for rebirth *)<BR>> waitingOn: Condition := NIL;<BR>> (* LL = cm; CV that we're blocked on *)<BR>> nextWaiter: T := NIL;<BR>> (* LL = cm; queue of threads waiting on the same CV *)<BR>> waitSema: WinNT.HANDLE := NIL;<BR>> (* binary semaphore for blocking during "Wait" *)<BR>> alertable: BOOLEAN := FALSE;<BR>> (* LL = cm; distinguishes between "Wait" and "AlertWait" *)<BR>> alerted: BOOLEAN := FALSE;<BR>> (* LL = cm; the alert flag, of course *)<BR>> completed: BOOLEAN := FALSE;<BR>> (* LL = threadMu; indicates that "result" is set *)<BR>> joined: BOOLEAN := FALSE;<BR>> (* LL = threadMu; "Join" or "AlertJoin" has already returned *)<BR>> id: Id;<BR>> (* LL = threadMu; unique ID of this thread *)<BR>> slot: INTEGER;<BR>> (* LL = threadMu; index into global array of active, slotted threads *)<BR>> END;<BR>> <BR>> (*------------------------------------------- Caches of critical sections ---*)<BR>> <BR>> CONST<BR>> CSectCacheSize = 20;<BR>> (* Everything should work OK if these are 0 *)<BR>> <BR>> VAR<BR>> cSectCache: ARRAY [0..CSectCacheSize-1] OF WinBase.LPCRITICAL_SECTION;<BR>> cSectCacheContents := 0;<BR>> <BR>> PROCEDURE AllocCSect(m: Mutex) =<BR>> (* LL = 0 *)<BR>> (* If we can take a critical section from the cache, <BR>> do so; otherwise create it. In any case, register the containing<BR>> Mutex with the GC so that we can clean-up on de-allocation. *)<BR>> VAR mcs: WinBase.LPCRITICAL_SECTION := NIL; lost_race := FALSE;<BR>> BEGIN<BR>> WinBase.EnterCriticalSection(cm);<BR>> IF cSectCacheContents > 0 THEN<BR>> DEC(cSectCacheContents);<BR>> m.cs := cSectCache[cSectCacheContents];<BR>> ELSE<BR>> WinBase.LeaveCriticalSection(cm);<BR>> mcs := NEW(WinBase.LPCRITICAL_SECTION);<BR>> WinBase.EnterCriticalSection(cm);<BR>> IF (m.cs = NIL) THEN<BR>> m.cs := mcs;<BR>> WinBase.InitializeCriticalSection(m.cs);<BR>> ELSE<BR>> (* somebody else beat us thru the preceding NEW *)<BR>> lost_race := TRUE;<BR>> END;<BR>> END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> <BR>> IF lost_race<BR>> THEN DISPOSE (mcs);<BR>> ELSE RTHeapRep.RegisterFinalCleanup(m, FreeCSect);<BR>> END;<BR>> END AllocCSect;<BR>> <BR>> PROCEDURE FreeCSect(r: REFANY (*Mutex*) ) =<BR>> (* LL < cm *)<BR>> (* Must not dereference any traced REF when called from GC *)<BR>> VAR m: Mutex := r;<BR>> BEGIN<BR>> WinBase.EnterCriticalSection(cm);<BR>> IF m.cs # NIL THEN<BR>> IF cSectCacheContents < CSectCacheSize THEN<BR>> cSectCache[cSectCacheContents] := m.cs;<BR>> INC(cSectCacheContents);<BR>> ELSE<BR>> WinBase.DeleteCriticalSection(m.cs);<BR>> DISPOSE(m.cs);<BR>> END;<BR>> m.cs := NIL;<BR>> END;<BR>> WinBase.LeaveCriticalSection(cm)<BR>> END FreeCSect;<BR>> <BR>> (*----------------------------------------------------------------- Mutex ---*)<BR>> (* Note: RTHooks.{Unlock,Lock}Mutex are the routines called directly by<BR>> the compiler. Acquire and Release are the routines exported through<BR>> the Thread interface *)<BR>> <BR>> PROCEDURE Acquire (m: Mutex) =<BR>> BEGIN<BR>> LockMutex (m);<BR>> END Acquire;<BR>> <BR>> PROCEDURE Release (m: Mutex) =<BR>> BEGIN<BR>> UnlockMutex (m);<BR>> END Release;<BR>> <BR>> PROCEDURE (*RTHooks.*)LockMutex (m: Mutex) =<BR>> BEGIN<BR>> IF (m.cs = NIL) THEN AllocCSect(m); END;<BR>> WinBase.EnterCriticalSection(m.cs);<BR>> IF m.held THEN Die("attempt to lock mutex already locked by self") END;<BR>> m.held := TRUE;<BR>> END LockMutex;<BR>> <BR>> PROCEDURE (*RTHooks.*)UnlockMutex(m: Mutex) =<BR>> BEGIN<BR>> IF NOT m.held THEN Die("attempt to release an unlocked mutex") END;<BR>> m.held := FALSE;<BR>> WinBase.LeaveCriticalSection(m.cs);<BR>> END UnlockMutex;<BR>> <BR>> (*---------------------------------------- Condition variables and Alerts ---*)<BR>> <BR>> PROCEDURE InnerWait(m: Mutex; c: Condition; self: T) =<BR>> (* LL = cm+m on entry; LL = m on exit *)<BR>> BEGIN<BR>> <* ASSERT( (self.waitingOn=NIL) AND (self.nextWaiter=NIL) ) *><BR>> self.waitingOn := c;<BR>> self.nextWaiter := c.waiters;<BR>> c.waiters := self;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> UnlockMutex(m);<BR>> IF WinBase.WaitForSingleObject(self.waitSema, WinBase.INFINITE) # 0 THEN<BR>> Choke();<BR>> END;<BR>> LockMutex(m);<BR>> END InnerWait;<BR>> <BR>> PROCEDURE InnerTestAlert(self: T) RAISES {Alerted} =<BR>> (* LL = cm on entry; LL = cm on normal exit, 0 on exception exit *)<BR>> (* If self.alerted, clear "alerted", leave cm and raise<BR>> "Alerted". *)<BR>> BEGIN<BR>> IF self.alerted THEN<BR>> self.alerted := FALSE;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> RAISE Alerted<BR>> END;<BR>> END InnerTestAlert;<BR>> <BR>> PROCEDURE AlertWait (m: Mutex; c: Condition) RAISES {Alerted} =<BR>> (* LL = m *)<BR>> VAR self := Self();<BR>> BEGIN<BR>> IF self = NIL THEN Die("AlertWait called from non-Modula-3 thread") END;<BR>> WinBase.EnterCriticalSection(cm);<BR>> InnerTestAlert(self);<BR>> self.alertable := TRUE;<BR>> InnerWait(m, c, self);<BR>> WinBase.EnterCriticalSection(cm);<BR>> InnerTestAlert(self);<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END AlertWait;<BR>> <BR>> PROCEDURE Wait (m: Mutex; c: Condition) =<BR>> (* LL = m *)<BR>> VAR self := Self();<BR>> BEGIN<BR>> IF self = NIL THEN Die("Wait called from non-Modula-3 thread") END;<BR>> WinBase.EnterCriticalSection(cm);<BR>> InnerWait(m, c, self);<BR>> END Wait;<BR>> <BR>> PROCEDURE DequeueHead(c: Condition) =<BR>> (* LL = cm *)<BR>> VAR t: T; prevCount: WinDef.LONG;<BR>> BEGIN<BR>> t := c.waiters; c.waiters := t.nextWaiter;<BR>> t.nextWaiter := NIL;<BR>> t.waitingOn := NIL;<BR>> t.alertable := FALSE;<BR>> IF WinBase.ReleaseSemaphore(t.waitSema, 1, ADR(prevCount)) = 0 THEN<BR>> Choke();<BR>> END;<BR>> END DequeueHead;<BR>> <BR>> PROCEDURE Signal (c: Condition) =<BR>> BEGIN<BR>> WinBase.EnterCriticalSection(cm);<BR>> IF c.waiters # NIL THEN DequeueHead(c) END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END Signal;<BR>> <BR>> PROCEDURE Broadcast (c: Condition) =<BR>> BEGIN<BR>> WinBase.EnterCriticalSection(cm);<BR>> WHILE c.waiters # NIL DO DequeueHead(c) END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END Broadcast;<BR>> <BR>> PROCEDURE Alert(t: T) =<BR>> VAR prevCount: WinDef.LONG; prev, next: T;<BR>> BEGIN<BR>> IF t = NIL THEN Die("Alert called from non-Modula-3 thread") END;<BR>> WinBase.EnterCriticalSection(cm);<BR>> t.alerted := TRUE;<BR>> IF t.alertable THEN<BR>> (* Dequeue from any CV and unblock from the semaphore *)<BR>> IF t.waitingOn # NIL THEN<BR>> next := t.waitingOn.waiters; prev := NIL;<BR>> WHILE next # t DO<BR>> <* ASSERT(next#NIL) *><BR>> prev := next; next := next.nextWaiter;<BR>> END;<BR>> IF prev = NIL THEN<BR>> t.waitingOn.waiters := t.nextWaiter<BR>> ELSE<BR>> prev.nextWaiter := t.nextWaiter;<BR>> END;<BR>> t.nextWaiter := NIL;<BR>> t.waitingOn := NIL;<BR>> END;<BR>> t.alertable := FALSE;<BR>> IF WinBase.ReleaseSemaphore(t.waitSema, 1, ADR(prevCount)) = 0 THEN<BR>> Choke();<BR>> END;<BR>> END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END Alert;<BR>> <BR>> PROCEDURE TestAlert(): BOOLEAN =<BR>> VAR self := Self(); result: BOOLEAN;<BR>> BEGIN<BR>> IF self = NIL THEN<BR>> (* Not created by Fork; not alertable *)<BR>> RETURN FALSE<BR>> ELSE<BR>> WinBase.EnterCriticalSection(cm);<BR>> result := self.alerted; IF result THEN self.alerted := FALSE END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> RETURN result<BR>> END;<BR>> END TestAlert;<BR>> <BR>> (*------------------------------------------------------------------ Self ---*)<BR>> <BR>> VAR<BR>> threadIndex: WinDef.DWORD;<BR>> (* read-only; TLS (Thread Local Storage) index *)<BR>> <BR>> VAR (* LL = threadMu *)<BR>> n_slotted := 0;<BR>> next_slot := 1;<BR>> slots : REF ARRAY OF T; (* NOTE: we don't use slots[0]. *)<BR>> <BR>> PROCEDURE Self (): T =<BR>> (* If not the initial thread and not created by Fork, returns NIL *)<BR>> VAR t: T; x := LOOPHOLE(WinBase.TlsGetValue(threadIndex), INTEGER);<BR>> BEGIN<BR>> IF (x < 1) THEN RETURN NIL; END;<BR>> t := slots[x];<BR>> IF (t.slot # x) THEN Die ("thread with bad slot!"); END;<BR>> RETURN t;<BR>> END Self;<BR>> <BR>> PROCEDURE SetSelf (t: T) =<BR>> (* LL = 0 *)<BR>> BEGIN<BR>> IF (slots [t.slot] # t) THEN Die ("unslotted thread!"); END;<BR>> IF WinBase.TlsSetValue(threadIndex, LOOPHOLE(t.slot, WinDef.LPVOID)) = 0<BR>> THEN Choke();<BR>> END;<BR>> END SetSelf;<BR>> <BR>> PROCEDURE AssignSlot (t: T): INTEGER =<BR>> (* LL = threadMu *)<BR>> BEGIN<BR>> (* make sure we have room to register this guy *)<BR>> IF (slots = NIL) THEN slots := NEW (REF ARRAY OF T, 20); END;<BR>> IF (n_slotted >= LAST (slots^)) THEN ExpandSlots (); END;<BR>> <BR>> (* look for an empty slot *)<BR>> WHILE (slots [next_slot] # NIL) DO<BR>> INC (next_slot);<BR>> IF (next_slot >= NUMBER (slots^)) THEN next_slot := 1; END;<BR>> END;<BR>> <BR>> INC (n_slotted);<BR>> t.slot := next_slot;<BR>> slots [next_slot] := t;<BR>> RETURN t.slot;<BR>> END AssignSlot;<BR>> <BR>> PROCEDURE FreeSlot (t: T) =<BR>> (* LL = threadMu *)<BR>> BEGIN<BR>> DEC (n_slotted);<BR>> WITH z = slots [t.slot] DO<BR>> IF (z # t) THEN Die ("unslotted thread!"); END;<BR>> z := NIL;<BR>> END;<BR>> t.slot := 0;<BR>> END FreeSlot;<BR>> <BR>> PROCEDURE ExpandSlots () =<BR>> VAR n := NUMBER (slots^); new := NEW (REF ARRAY OF T, n+n);<BR>> BEGIN<BR>> SUBARRAY (new^, 0, n) := slots^;<BR>> slots := new;<BR>> END ExpandSlots;<BR>> <BR>> (*------------------------------------------------------------ Fork, Join ---*)<BR>> <BR>> CONST<BR>> MaxIdle = 20;<BR>> <BR>> VAR (* LL=threadMu *)<BR>> threadMu: Mutex;<BR>> allThreads: T := NIL; (* global list of registered threads *)<BR>> idleThreads: T := NIL; (* global list of idle threads *)<BR>> nIdle := 0;<BR>> <BR>> PROCEDURE CreateT(): T =<BR>> (* LL < threadMu, because allocated a traced reference may cause<BR>> the allocator to start a collection which will call SuspendOthers<BR>> which will try to acquire threadMu. *)<BR>> BEGIN<BR>> RETURN NEW(T, waitSema := WinBase.CreateSemaphore(NIL, 0, 1, NIL),<BR>> cond := NEW(Condition));<BR>> END CreateT;<BR>> <BR>> (* ThreadBase calls ThreadMain after finding (approximately) where<BR>> its stack begins. This dance ensures that all of ThreadMain's<BR>> traced references are within the stack scanned by the collector. *)<BR>> <BR>> PROCEDURE ThreadBase(param: WinDef.DWORD): WinDef.DWORD =<BR>> VAR self: T; x := LOOPHOLE(param, INTEGER);<BR>> BEGIN<BR>> LockMutex(threadMu);<BR>> self := slots[x];<BR>> self.stackbase := ADR(self);<BR>> UnlockMutex(threadMu);<BR>> ThreadMain(self);<BR>> RETURN 0;<BR>> END ThreadBase;<BR>> <BR>> PROCEDURE ThreadMain(self: T) =<BR>> TYPE<BR>> ObjRef = UNTRACED REF MethodList;<BR>> MethodList = UNTRACED REF RECORD typecode: INTEGER; method0: ADDRESS END;<BR>> VAR next_self: T; cl: Closure; res: REFANY;<BR>> BEGIN<BR>> LOOP (* The incarnation loop. *)<BR>> SetSelf (self);<BR>> <BR>> LockMutex(threadMu);<BR>> cl := self.closure;<BR>> self.id := nextId; INC (nextId);<BR>> UnlockMutex(threadMu);<BR>> <BR>> IF (cl = NIL) THEN<BR>> Die ("NIL closure passed to Thread.Fork!");<BR>> ELSIF (LOOPHOLE (cl, ObjRef)^^.method0 = NIL) THEN<BR>> Die ("NIL apply method passed to Thread.Fork!");<BR>> END;<BR>> <BR>> res := cl.apply();<BR>> <BR>> next_self := NIL;<BR>> IF nIdle < MaxIdle THEN<BR>> (* apparently the cache isn't full, although we don't hold threadMu<BR>> so we can't be certain... *)<BR>> next_self := NEW(T);<BR>> END;<BR>> <BR>> LockMutex(threadMu);<BR>> self.result := res;<BR>> self.completed := TRUE;<BR>> <BR>> IF next_self # NIL THEN<BR>> (* transplant the guts of "self" into next_self *)<BR>> next_self.handle := self.handle;<BR>> next_self.stackbase := self.stackbase;<BR>> next_self.waitSema := self.waitSema;<BR>> next_self.cond := self.cond;<BR>> <BR>> (* put "next_self" on the list of all threads *)<BR>> next_self.next := allThreads;<BR>> next_self.prev := allThreads.prev;<BR>> allThreads.prev.next := next_self;<BR>> allThreads.prev := next_self;<BR>> <BR>> (* put "next_self" on the list of idle threads *)<BR>> next_self.nextIdle := idleThreads;<BR>> idleThreads := next_self;<BR>> INC(nIdle);<BR>> <BR>> (* finish making "self" an orphan *)<BR>> IF allThreads = self THEN allThreads := self.next; END;<BR>> self.next.prev := self.prev;<BR>> self.prev.next := self.next;<BR>> self.next := NIL;<BR>> self.prev := NIL;<BR>> self.handle := NIL;<BR>> self.stackbase := NIL;<BR>> END;<BR>> UnlockMutex(threadMu);<BR>> <BR>> Broadcast(self.cond); (* let everybody know that "self" is done *)<BR>> <BR>> IF next_self = NIL THEN EXIT; END;<BR>> self := next_self;<BR>> IF WinBase.WaitForSingleObject(self.waitSema, WinBase.INFINITE) # 0 THEN<BR>> Choke();<BR>> END;<BR>> END;<BR>> <BR>> (* remove ourself from the list of all threads *)<BR>> LockMutex(threadMu);<BR>> IF allThreads = self THEN allThreads := self.next; END;<BR>> self.next.prev := self.prev;<BR>> self.prev.next := self.next;<BR>> self.next := NIL;<BR>> self.prev := NIL;<BR>> IF WinBase.CloseHandle(self.waitSema) = 0 THEN Choke() END;<BR>> IF WinBase.CloseHandle(self.handle) = 0 THEN Choke() END;<BR>> self.handle := NIL;<BR>> self.waitSema := NIL;<BR>> FreeSlot (self);<BR>> UnlockMutex(threadMu);<BR>> END ThreadMain;<BR>> <BR>> PROCEDURE Fork(closure: Closure): T =<BR>> VAR<BR>> t: T := NIL;<BR>> id, stack_size: WinDef.DWORD;<BR>> prevCount: WinDef.LONG;<BR>> new_born: BOOLEAN;<BR>> BEGIN<BR>> (* determine the initial size of the stack for this thread *)<BR>> stack_size := default_stack;<BR>> TYPECASE closure OF SizedClosure (scl) =><BR>> IF scl.stackSize # 0 THEN <BR>> stack_size := scl.stackSize * BYTESIZE(INTEGER);<BR>> END;<BR>> ELSE (*skip*)<BR>> END;<BR>> <BR>> (* try the cache for a thread *)<BR>> LockMutex(threadMu);<BR>> IF nIdle > 0 THEN<BR>> new_born := FALSE;<BR>> <* ASSERT(idleThreads # NIL) *><BR>> DEC(nIdle);<BR>> t := idleThreads;<BR>> idleThreads := t.nextIdle;<BR>> t.nextIdle := NIL;<BR>> t.slot := AssignSlot (t);<BR>> ELSE (* empty cache => we need a fresh thread *)<BR>> new_born := TRUE;<BR>> UnlockMutex(threadMu);<BR>> t := CreateT();<BR>> LockMutex(threadMu);<BR>> t.slot := AssignSlot (t);<BR>> t.handle := WinBase.CreateThread(NIL, stack_size,<BR>> LOOPHOLE(ThreadBase, WinBase.LPTHREAD_START_ROUTINE),<BR>> LOOPHOLE(t.slot,WinDef.LPVOID), WinBase.CREATE_SUSPENDED, ADR(id));<BR>> t.next := allThreads;<BR>> t.prev := allThreads.prev;<BR>> allThreads.prev.next := t;<BR>> allThreads.prev := t;<BR>> END;<BR>> IF (t.handle = NIL) THEN Choke() END;<BR>> t.closure := closure;<BR>> UnlockMutex(threadMu);<BR>> <BR>> IF new_born THEN<BR>> IF WinBase.ResumeThread(t.handle) = -1 THEN Choke() END;<BR>> ELSE<BR>> IF WinBase.ReleaseSemaphore(t.waitSema, 1, ADR(prevCount)) = 0 THEN<BR>> Choke();<BR>> END;<BR>> END;<BR>> <BR>> RETURN t<BR>> END Fork;<BR>> <BR>> PROCEDURE Join(t: T): REFANY =<BR>> VAR res: REFANY;<BR>> BEGIN<BR>> LockMutex(threadMu);<BR>> IF t.joined THEN Die("attempt to join with thread twice"); END;<BR>> WHILE NOT t.completed DO Wait(threadMu, t.cond) END;<BR>> res := t.result;<BR>> t.result := NIL;<BR>> t.joined := TRUE;<BR>> UnlockMutex(threadMu);<BR>> RETURN res;<BR>> END Join;<BR>> <BR>> PROCEDURE AlertJoin(t: T): REFANY RAISES {Alerted} =<BR>> VAR res: REFANY;<BR>> BEGIN<BR>> LockMutex(threadMu);<BR>> TRY<BR>> IF t.joined THEN Die("attempt to join with thread twice"); END;<BR>> WHILE NOT t.completed DO AlertWait(threadMu, t.cond) END;<BR>> res := t.result;<BR>> t.result := NIL;<BR>> t.joined := TRUE;<BR>> FINALLY<BR>> UnlockMutex(threadMu);<BR>> END;<BR>> RETURN res;<BR>> END AlertJoin;<BR>> <BR>> (*------------------------------------------------ timer-based preemption ---*)<BR>> <BR>> PROCEDURE SetSwitchingInterval (<*UNUSED*> usec: CARDINAL) =<BR>> BEGIN<BR>> END SetSwitchingInterval;<BR>> <BR>> (*---------------------------------------------------- Scheduling support ---*)<BR>> <BR>> PROCEDURE Pause(n: LONGREAL) =<BR>> VAR amount, thisTime: LONGREAL;<BR>> CONST Limit = FLOAT(LAST(CARDINAL), LONGREAL) / 1000.0D0 - 1.0D0;<BR>> BEGIN<BR>> amount := n;<BR>> WHILE amount > 0.0D0 DO<BR>> thisTime := MIN (Limit, amount);<BR>> amount := amount - thisTime;<BR>> WinBase.Sleep(ROUND(thisTime*1000.0D0));<BR>> END;<BR>> END Pause;<BR>> <BR>> PROCEDURE AlertPause(n: LONGREAL) RAISES {Alerted} =<BR>> VAR amount, thisTime: LONGREAL;<BR>> CONST Limit = FLOAT(LAST(CARDINAL), LONGREAL) / 1000.0D0 - 1.0D0;<BR>> VAR self: T;<BR>> BEGIN<BR>> self := Self();<BR>> amount := n;<BR>> WHILE amount > 0.0D0 DO<BR>> thisTime := MIN (Limit, amount);<BR>> amount := amount - thisTime;<BR>> WinBase.EnterCriticalSection(cm);<BR>> InnerTestAlert(self);<BR>> self.alertable := TRUE;<BR>> <* ASSERT(self.waitingOn = NIL) *><BR>> WinBase.LeaveCriticalSection(cm);<BR>> EVAL WinBase.WaitForSingleObject(self.waitSema, ROUND(thisTime*1.0D3));<BR>> WinBase.EnterCriticalSection(cm);<BR>> self.alertable := FALSE;<BR>> IF self.alerted THEN<BR>> (* Sadly, the alert might have happened after we timed out on the<BR>> semaphore and before we entered "cm". In that case, we need to<BR>> decrement the semaphore's count *)<BR>> EVAL WinBase.WaitForSingleObject(self.waitSema, 0);<BR>> InnerTestAlert(self);<BR>> END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END;<BR>> END AlertPause;<BR>> <BR>> PROCEDURE Yield() =<BR>> BEGIN<BR>> WinBase.Sleep(0);<BR>> END Yield;<BR>> <BR>> (*--------------------------------------------------- Stack size controls ---*)<BR>> <BR>> PROCEDURE GetDefaultStackSize(): CARDINAL=<BR>> BEGIN<BR>> RETURN default_stack DIV BYTESIZE (INTEGER);<BR>> END GetDefaultStackSize;<BR>> <BR>> PROCEDURE MinDefaultStackSize(new_min: CARDINAL)=<BR>> BEGIN<BR>> default_stack := MAX (default_stack, new_min * BYTESIZE (INTEGER));<BR>> END MinDefaultStackSize;<BR>> <BR>> PROCEDURE IncDefaultStackSize(inc: CARDINAL)=<BR>> BEGIN<BR>> INC (default_stack, inc * BYTESIZE (INTEGER));<BR>> END IncDefaultStackSize;<BR>> <BR>> (*-------------------------------------------- Exception handling support ---*)<BR>> <BR>> VAR handlersIndex: INTEGER;<BR>> <BR>> PROCEDURE GetCurrentHandlers(): ADDRESS=<BR>> BEGIN<BR>> RETURN WinBase.TlsGetValue(handlersIndex);<BR>> END GetCurrentHandlers;<BR>> <BR>> PROCEDURE SetCurrentHandlers(h: ADDRESS)=<BR>> BEGIN<BR>> EVAL WinBase.TlsSetValue(handlersIndex, h);<BR>> END SetCurrentHandlers;<BR>> <BR>> PROCEDURE PushEFrame (frame: ADDRESS) =<BR>> TYPE Frame = UNTRACED REF RECORD next: ADDRESS END;<BR>> VAR f := LOOPHOLE (frame, Frame);<BR>> BEGIN<BR>> f.next := WinBase.TlsGetValue(handlersIndex);<BR>> EVAL WinBase.TlsSetValue(handlersIndex, f);<BR>> END PushEFrame;<BR>> <BR>> PROCEDURE PopEFrame (frame: ADDRESS) =<BR>> BEGIN<BR>> EVAL WinBase.TlsSetValue(handlersIndex, frame);<BR>> END PopEFrame;<BR>> <BR>> (*--------------------------------------------- Garbage collector support ---*)<BR>> <BR>> VAR<BR>> suspend_mu : Mutex;<BR>> suspend_cnt : CARDINAL := 0; (* LL = suspend_mu *)<BR>> <BR>> PROCEDURE SuspendOthers () =<BR>> (* LL=0. Always bracketed with ResumeOthers, which will unlock threadMu *)<BR>> VAR t: T; self := Self (); cnt: CARDINAL;<BR>> BEGIN<BR>> LOCK suspend_mu DO<BR>> cnt := suspend_cnt;<BR>> INC (suspend_cnt);<BR>> END;<BR>> <BR>> IF (cnt = 0) THEN<BR>> LockMutex(threadMu);<BR>> <BR>> WinBase.EnterCriticalSection(cm);<BR>> (* We must hold 'cm' to guarantee that no suspended thread holds it.<BR>> Otherwise, when the collector tries to acquire a mutex or signal<BR>> a condition, it will deadlock with the suspended thread that<BR>> holds 'cm'. *)<BR>> <BR>> t := self.next;<BR>> WHILE (t # self) DO<BR>> IF WinBase.SuspendThread(t.handle) = -1 THEN Choke() END;<BR>> t := t.next;<BR>> END;<BR>> WinBase.LeaveCriticalSection(cm);<BR>> END;<BR>> END SuspendOthers;<BR>> <BR>> PROCEDURE ResumeOthers () =<BR>> (* LL=threadMu. Always preceded by SuspendOthers, which locks threadMu *)<BR>> VAR t: T; self := Self (); cnt: CARDINAL;<BR>> BEGIN<BR>> LOCK suspend_mu DO<BR>> DEC (suspend_cnt);<BR>> cnt := suspend_cnt;<BR>> END;<BR>> <BR>> IF (cnt = 0) THEN<BR>> t := self.next;<BR>> WHILE (t # self) DO<BR>> IF WinBase.ResumeThread(t.handle) = -1 THEN Choke() END;<BR>> t := t.next;<BR>> END;<BR>> UnlockMutex(threadMu);<BR>> END;<BR>> END ResumeOthers;<BR>> <BR>> PROCEDURE ProcessStacks (p: PROCEDURE (start, stop: ADDRESS)) =<BR>> (* LL=threadMu. Only called within {SuspendOthers, ResumeOthers} *)<BR>> CONST UserRegs = Word.Or(ThreadContext.CONTEXT_CONTROL,<BR>> ThreadContext.CONTEXT_INTEGER);<BR>> VAR t := allThreads; context: ThreadContext.CONTEXT; fixed_SP: ADDRESS;<BR>> BEGIN<BR>> REPEAT<BR>> IF (t.stackbase # NIL) THEN<BR>> context.ContextFlags := UserRegs;<BR>> IF WinBase.GetThreadContext(t.handle, ADR(context))=0 THEN Choke() END;<BR>> fixed_SP := LOOPHOLE (context.Esp, ADDRESS);<BR>> IF (t.stackbase - fixed_SP) > 10000 THEN<BR>> fixed_SP := VerifySP (fixed_SP, t.stackbase);<BR>> END;<BR>> p(fixed_SP, t.stackbase); (* Process the stack *)<BR>> p(ADR(context.Edi), ADR(context.Eip)); (* Process the registers *)<BR>> END;<BR>> t := t.next;<BR>> UNTIL (t = allThreads);<BR>> END ProcessStacks;<BR>> <BR>> PROCEDURE VerifySP (start, stop: ADDRESS): ADDRESS =<BR>> (* Apparently, Win95 will lie about a thread's stack pointer! *)<BR>> (* Verify that the claimed stack pages are really readable... *)<BR>> CONST PageSize = 4096;<BR>> CONST N = BYTESIZE (info);<BR>> VAR info: WinNT.MEMORY_BASIC_INFORMATION;<BR>> BEGIN<BR>> <BR>> (******<BR>> RTIO.PutText ("GC: suspicious stack: [");<BR>> RTIO.PutAddr (start);<BR>> RTIO.PutText ("..");<BR>> RTIO.PutAddr (stop);<BR>> RTIO.PutText ("]\n");<BR>> RTIO.Flush ();<BR>> ******)<BR>> <BR>> info.BaseAddress := LOOPHOLE (stop-1, ADDRESS);<BR>> LOOP<BR>> IF (info.BaseAddress <= start) THEN<BR>> info.BaseAddress := start;<BR>> EXIT;<BR>> END;<BR>> <BR>> IF WinBase.VirtualQuery (info.BaseAddress, ADR (info), N) # N THEN<BR>> Choke();<BR>> END;<BR>> <BR>> (*******<BR>> RTIO.PutText (" --> "); RTIO.PutAddr (info.BaseAddress);<BR>> RTIO.PutText (" "); RTIO.PutAddr (info.AllocationBase);<BR>> RTIO.PutText (" "); RTIO.PutHex (info.AllocationProtect);<BR>> RTIO.PutText (" "); RTIO.PutHex (info.RegionSize);<BR>> RTIO.PutText (" "); RTIO.PutHex (info.State);<BR>> RTIO.PutText (" "); RTIO.PutHex (info.Protect);<BR>> RTIO.PutText (" "); RTIO.PutHex (info.Type);<BR>> RTIO.PutText ("\n");<BR>> *******)<BR>> <BR>> (* is this chunk readable? *)<BR>> IF (info.Protect # WinNT.PAGE_READWRITE)<BR>> AND (info.Protect # WinNT.PAGE_READONLY) THEN<BR>> (* nope, return the base of the last good chunk *)<BR>> INC (info.BaseAddress, info.RegionSize);<BR>> EXIT;<BR>> END;<BR>> <BR>> (* yep, try the next chunk *)<BR>> DEC (info.BaseAddress, PageSize);<BR>> END;<BR>> <BR>> (********<BR>> RTIO.PutText (" ==> [");<BR>> RTIO.PutAddr (info.BaseAddress);<BR>> RTIO.PutText ("..");<BR>> RTIO.PutAddr (stop);<BR>> RTIO.PutText ("]");<BR>> RTIO.PutText ("\n");<BR>> RTIO.Flush ();<BR>> *******)<BR>> <BR>> RETURN info.BaseAddress;<BR>> END VerifySP;<BR>> <BR>> (*------------------------------------------------------------ misc. junk ---*)<BR>> <BR>> PROCEDURE MyId(): Id RAISES {}=<BR>> VAR self := Self ();<BR>> BEGIN<BR>> RETURN self.id;<BR>> END MyId;<BR>> <BR>> (*---------------------------------------------------------------- errors ---*)<BR>> <BR>> PROCEDURE Die(msg: TEXT) =<BR>> BEGIN<BR>> RTMisc.FatalError ("ThreadWin32.m3", 721, "Thread client error: ", msg);<BR>> END Die;<BR>> <BR>> PROCEDURE Choke() =<BR>> BEGIN<BR>> RTMisc.FatalErrorI (<BR>> "ThreadWin32.m3, line 726: Windows OS failure, GetLastError = ",<BR>> WinBase.GetLastError ());<BR>> END Choke;<BR>> <BR>> (*-------------------------------------------------------- Initialization ---*)<BR>> <BR>> <BR>> PROCEDURE Init() =<BR>> VAR<BR>> self: T;<BR>> threadhandle, processhandle: WinNT.HANDLE;<BR>> BEGIN<BR>> handlersIndex := WinBase.TlsAlloc();<BR>> IF handlersIndex < 0 THEN Choke() END;<BR>> <BR>> threadIndex := WinBase.TlsAlloc();<BR>> IF threadIndex < 0 THEN Choke() END;<BR>> <BR>> cm := NEW(WinBase.LPCRITICAL_SECTION);<BR>> WinBase.InitializeCriticalSection(cm);<BR>> <BR>> suspend_mu := NEW(Mutex);<BR>> suspend_cnt := 0;<BR>> <BR>> threadMu := NEW(Mutex);<BR>> self := CreateT();<BR>> <BR>> LockMutex(threadMu);<BR>> threadhandle := WinBase.GetCurrentThread();<BR>> processhandle := WinBase.GetCurrentProcess();<BR>> IF WinBase.DuplicateHandle(processhandle, threadhandle, processhandle,<BR>> LOOPHOLE(ADR(self.handle), WinNT.PHANDLE), 0,<BR>> 0, WinNT.DUPLICATE_SAME_ACCESS) = 0 THEN<BR>> Choke();<BR>> END;<BR>> self.slot := AssignSlot (self);<BR>> self.id := nextId; INC (nextId);<BR>> self.next := self;<BR>> self.prev := self;<BR>> allThreads := self;<BR>> self.stackbase := RTLinker.info.bottom_of_stack;<BR>> IF self.stackbase = NIL THEN Choke(); END;<BR>> UnlockMutex(threadMu);<BR>> SetSelf (self);<BR>> END Init;<BR>> <BR>> BEGIN<BR>> END ThreadWin32.<BR><BR><br /><hr />Climb to the top of the charts!�Play the word scramble challenge with star power. <a href='http://club.live.com/star_shuffle.aspx?icid=starshuffle_wlmailtextlink_jan' target='_new'>Play now!</a></body>

</html>