OberonCore

Более чем кандидатом, ему придется им стать. Мы это уже обсуждали.

Кстати, одну интересную штуку так никто и не усек...

ведутся работы по развитию и применению ББ для серверных систем, в частности, построению на нем распределенной СУБД и т.п. - и вот в этих продуктах мы уже не можем завязываться на GPL.

Никак, ясное дело. Но создание псевпомодуля AO - то же расширение языка, хоть и замаскированное.

Иногда использовал, но закономерностей не улавил.

MODULE Ao;
(**
project = "Active BlackBox"
organization = "blackbox.metasystems.ru"
contributors = "OCSE Metasystems, Ltd."
version = "1.5 beta, based on BlackBox 1.5"
copyright = "Docu/Active/About"
license = "Docu/Active/License"
changes = ""
issues = ""

**)

IMPORT Kernel, Synch, Mem, Details, S := SYSTEM, HostSynch;

CONST
idle* = {0};
low* = {1};
high* = {0, 1};
bound* = {2};
copyRefs* = {3};
safe* = {4};
notCloseTask* = {5};
(* awaitOrComplete* = {6}; *)

CONST
regEax = 0;
regEbx = 3;
regEsi = 6;
regEdi = 7;
regFp = 5;
regSp = 4;

TYPE
StartInfo = POINTER TO RECORD
flags: SET;
body: PROCEDURE;
params: POINTER TO ARRAY OF BYTE;
refs: POINTER TO ARRAY OF POINTER TO ARRAY OF BYTE;
locals: POINTER TO ARRAY OF BYTE;
ebx, esi, edi: INTEGER;
barrier: Synch.CriticalSection;
continue: BOOLEAN
END;

Stack = RECORD
base, fp, sp: INTEGER
END;

Stop* = RECORD
stop: BOOLEAN
END;

Await = POINTER TO RECORD
next: Await;
sem: Synch.Semaphore
END;

MONITOR* = POINTER TO RECORD (Details.Detail)
locker: INTEGER;
cs: Synch.CriticalSection;
update: BOOLEAN;
await, end: Await
END;

TLS = POINTER TO RECORD
flags: SET;
sp: INTEGER;
exclStack: ARRAY 128 OF RECORD
ret: INTEGER;
object: MONITOR
END
END;

AwaitHeap = POINTER TO RECORD (Mem.SynchedHeap) END;

VAR
tls: Synch.LocalStorage;
awaitHeap: AwaitHeap;
heapCS: Synch.CriticalSection;

PROCEDURE [code] JmpEbx
0FFH, 0E3H; (*FF 11 100 011 (EBX) *)
PROCEDURE [code] PushEbp
55H;
PROCEDURE [code] MovEbpEsp
8BH, 0ECH;
PROCEDURE [code] PopEbp
5DH;
PROCEDURE [code] MovEspEbp
8BH, 0E5H;
PROCEDURE [code] PushEdi
57H;
PROCEDURE [code] PushEsi
56H;
PROCEDURE [code] PushEbx
53H;
PROCEDURE [code] PushEax
50H;
PROCEDURE [code] PopEsi
5EH;
PROCEDURE [code] PopEdi
5FH;
PROCEDURE [code] PopEbx
5BH;
PROCEDURE [code] PopEax
58H;
PROCEDURE [code] Ret
0C3H;
PROCEDURE [code] Ret8
0C2H, 08H, 00H;
PROCEDURE [code] Push0
6AH, 00H;
PROCEDURE [code] AddEsp12
83H, 0C4H, 0F4H;
PROCEDURE [code] AddEsp24
83H, 0C4H, 0E8H;
PROCEDURE [code] LeaEspEbp12
8DH, 65H, 0F4H;

PROCEDURE CopyParams (IN this: Stack; IN info: Mem.ProcInfo; VAR new: StartInfo; flags: SET; OUT ok: BOOLEAN);
VAR p, par, a, len, i, k: INTEGER;
tag: Kernel.Type;
adrs, offs: ARRAY 32 OF INTEGER;
(* proc desc *)
ref: INTEGER;
mode, form: SHORTCHAR;
desc: Kernel.Type;
x: INTEGER;
name: Kernel.Name;
BEGIN
ok := TRUE;
IF info.nOfPars > 0 THEN
flags := flags * copyRefs;
NEW(new.refs, info.nOfPars);
(* chek varpar params *)
FOR par := 0 TO info.nOfPars-1 DO
ref := info.refFirstPar;
Kernel.GetRefVar(ref, mode, form, desc, x, name);
offs[par] := x;
IF (mode = 3X) OR (form = 12X) & (desc.size = 0) THEN
p := this.fp + x;
S.GET(p, a);
IF (this.base >= a) & (a >= this.fp) THEN (* if varpar points to current stack... *)
IF flags = {} THEN
ok := FALSE;
RETURN
ELSIF flags = copyRefs THEN
IF form = 11X THEN
S.GET(p+4, tag);
len := tag.size
ELSIF form = 12X THEN
IF desc.size = 0 THEN
len := 1;
FOR i := 1 TO desc.id DIV 16 MOD 16 DO
S.GET(p+4*i, k);
len := len * k
END;
len := len * Mem.TypeSize(desc.base[0])
ELSE
len := desc.size * Mem.TypeSize(desc.base[0])
END
ELSE
len := MAX(Mem.SizeOfPar(1X, form, NIL), 4)
END;
NEW(new.refs[par], len);
S.MOVE(a, S.ADR(new.refs[par][0]), len);
adrs[par] := S.ADR(new.refs[par][0])
END
ELSE
adrs[par] := a
END
ELSE
adrs[par] := 0
END
END;
(* copy params *)
NEW(new.params, info.parEnd - info.parBeg);
S.MOVE(this.fp + info.parBeg, S.ADR(new.params[0]), info.parEnd - info.parBeg);
(* fixup varpars *)
FOR par := 0 TO info.nOfPars-1 DO
IF adrs[par] # 0 THEN
S.PUT(S.ADR(new.params[0]) + offs[par] - info.parBeg, adrs[par])
END
END
END
END CopyParams;

PROCEDURE CopyLocals (IN this: Stack; VAR new: StartInfo);
VAR len: INTEGER;
BEGIN
len := this.fp - this.sp;
IF len > 0 THEN
NEW(new.locals, len);
S.MOVE(this.sp, S.ADR(new.locals[0]), len)
END
END CopyLocals;

PROCEDURE ^ Starter2 (self: INTEGER; inf: ANYPTR);
PROCEDURE ^ Restore (id: INTEGER; info: ANYPTR; OUT restored: BOOLEAN);

(* 20 - wrong flags
21 - unknown caller module
22 - unexpected local reference
23 - too many param
24 - can not be bound
*)

PROCEDURE ACTIVE* (flags: SET);
VAR ebx, esi, edi: INTEGER;
new: StartInfo;
stackSize: INTEGER;
ret, stackUp, fpUp: INTEGER;
this: Stack;
info: Mem.ProcInfo;
(* proc info *)
procAdr: INTEGER;
procName: Kernel.Name;
id: INTEGER;
ok: BOOLEAN;
obj: ANYPTR;
BEGIN
S.GETREG(regEbx, ebx); S.GETREG(regEsi, esi); S.GETREG(regEdi, edi);
NEW(new); new.ebx := ebx; new.esi := esi; new.edi := edi;
new.barrier := Synch.dir.NewCS(); new.barrier.ENTER;
new.flags := flags;
Kernel.cGetTaskStack(Kernel.cThisTask(), this.base, this.fp, this.sp);
this.sp := this.fp + 8; (* get sp of caller proc *)
S.GET(this.fp+4, new.body); (* get addr of caller proc ACTIVE section (RET addr of this proc) *)
S.GET(this.fp, this.fp); (* get frame of caller proc *)
S.GET(this.fp+4, ret); (* get RET addr of caller proc *)
Mem.GetProcInfo(S.VAL(INTEGER, new.body), info);
ASSERT(Mem.firstStmt IN info.ext, 20);
Kernel.GetRefProc(info.ref, procAdr, procName);
CopyParams(this, info, new, flags, ok);
ASSERT(ok, 24);
CopyLocals(this, new);
stackSize := 4000H;
IF new.params # NIL THEN INC(stackSize, LEN(new.params)) END;
IF new.locals # NIL THEN INC(stackSize, LEN(new.locals)) END;
Kernel.cCreateTask(Starter2, new, stackSize, "Active proc: " + procName, FALSE, id);
Kernel.cSetNativeMod(id, info.mod);
IF flags * bound = bound THEN
IF (info.nOfPars = 0) OR ~(Mem.object IN info.ext) THEN
new.barrier.LEAVE;
HALT(21)
END;
S.GET(this.fp + 8, obj);
ASSERT(obj # NIL, 22);
Kernel.cSetTaskOwner(id, obj);
obj := NIL
END;
IF flags * safe = safe THEN
Kernel.cSetTaskRestore(id, Restore, NIL)
END;
IF flags * {0, 1} = idle THEN
Kernel.cSetPriority(id, Kernel.priorIdle)
ELSIF flags * {0, 1} = low THEN
Kernel.cSetPriority(id, Kernel.priorBelowNormal)
ELSIF flags * {0, 1} = high THEN
Kernel.cSetPriority(id, Kernel.priorAboveNormal)
END;
new.continue := TRUE;
new.barrier.LEAVE;
stackUp := this.fp + info.parEnd; (* deleting params of caller proc *)
DEC(stackUp, 4); (* ACTIVE param size, for RET n. *)
S.GET(this.fp, fpUp);
S.PUT(stackUp-4, ret);
S.PUT(stackUp-8, fpUp);
S.PUTREG(regFp, stackUp-8);
S.PUTREG(0, 0) (* Clear return value in AX *)
END ACTIVE;

(* Old starter *)

PROCEDURE Starter2 (self: INTEGER; inf: ANYPTR);
VAR ret, fp, sp, len, newFp: INTEGER;
end, ok: BOOLEAN;
t: TLS;
PROCEDURE FixRet;
VAR fp: INTEGER;
BEGIN
S.GETREG(regFp, fp);
S.GET(fp + 4, ret)
END FixRet;
BEGIN
end := FALSE;
WITH inf: StartInfo DO
inf.barrier.ENTER; inf.barrier.LEAVE;
IF ~inf.continue THEN Kernel.cCloseTask(self, ok) END;
t := tls.Get()(TLS);
t.flags := inf.flags;
S.GETREG(regSp, sp);
S.GETREG(regFp, fp);
FixRet;
IF ~end THEN
end := TRUE;
IF inf.params # NIL THEN
len := LEN(inf.params);
S.MOVE(S.ADR(inf.params[0]), sp - len, len);
DEC(sp, len)
END;
S.PUT(sp - 4, ret);
S.PUT(sp - 8, fp);
DEC(sp, ;
newFp := sp;
IF inf.locals # NIL THEN
len := LEN(inf.locals);
S.MOVE(S.ADR(inf.locals[0]), sp - len, len);
DEC(sp, len)
END;
S.PUT(sp-4, inf.body);
DEC(sp, 4);
S.PUTREG(regEbx, inf.ebx);
S.PUTREG(regEsi, inf.esi);
S.PUTREG(regEdi, inf.edi);
S.PUTREG(regSp, sp);
S.PUTREG(regFp, newFp);
Ret (* go to active procedure body *)
ELSE
IF inf.flags * notCloseTask = {} THEN
Kernel.cCloseTask(self, ok)
END
END
END
END Starter2;

PROCEDURE Restore (id: INTEGER; info: ANYPTR; OUT restored: BOOLEAN);
BEGIN
restored := TRUE
END Restore;

PROCEDURE (VAR s: Stop) Stop*, NEW;
BEGIN
s.stop := TRUE
END Stop;

PROCEDURE (VAR s: Stop) ShouldStop* (): BOOLEAN, NEW;
BEGIN
RETURN Kernel.cShouldComplete(Kernel.cThisTask()) OR s.stop
END ShouldStop;

PROCEDURE (VAR s: Stop) Reset*, NEW;
BEGIN
s.stop := FALSE
END Reset;

PROCEDURE Sleep* (ms: INTEGER);
BEGIN
Kernel.cSleep(ms)
END Sleep;

PROCEDURE Turn* ;
BEGIN
Kernel.cTurn
END Turn;

PROCEDURE (m: MONITOR) Init- (obj: ANYPTR);
BEGIN
Details.AssertSingle(obj, m);
m.locker := -1;
m.cs := Synch.dir.NewCS()
END Init;

PROCEDURE (h: AwaitHeap) New (): Await;
VAR a: Await;
BEGIN
NEW(a);
a.sem := HostSynch.NewSysSemaphore(0); (* Synch.dir.NewSem(0); *)
RETURN a
END New;

PROCEDURE (h: AwaitHeap) Utile (ptr: ANYPTR);
BEGIN
WITH ptr: Await DO
ptr.next := NIL
END
END Utile;

(* Old ret hook *)

PROCEDURE RetHook;
END RetHook;

PROCEDURE [noframe] RetHookNF ;
VAR t: TLS;
mon: MONITOR;
aw: Await;
ret, fp: INTEGER;
BEGIN
PushEbp; (* Reserve place for ret addr substitution *)
PushEax;
PushEdi;
PushEsi;
PushEbp;
MovEbpEsp;
Push0;
Push0;
AddEsp12;
Push0;
t := tls.Get()(TLS);
ASSERT(t.sp > 0, 100);
DEC(t.sp);
mon := t.exclStack[t.sp].object;
ret := t.exclStack[t.sp].ret;
IF mon.update THEN
aw := mon.await;
WHILE aw # NIL DO
aw.sem.POST(1);
aw := aw.next
END;
mon.await := NIL;
mon.end := NIL;
mon.update := FALSE
END;
mon.locker := -1;
mon.cs.LEAVE;
S.GETREG(regFp, fp);
S.PUT(fp+16, ret);
MovEspEbp;
PopEbp;
PopEsi;
PopEdi;
PopEax;
Ret
END RetHookNF;

(* 20 - wrong caller signature;
21 - recursive lock
*)

PROCEDURE EXCLUSIVE* ;
VAR inf: Mem.ProcInfo;
ret: INTEGER;
obj: ANYPTR;
mon: MONITOR;
fp, adr: INTEGER;
t: TLS;
BEGIN
S.GETREG(regFp, fp);
S.GET(fp+4, ret);
Mem.GetProcInfo(ret, inf);
ASSERT(Mem.firstStmt IN inf.ext, 20);
ASSERT(Mem.object IN inf.ext, 21);
S.GET(fp, adr);
S.GET(adr + 8, obj);
ASSERT(obj # NIL, 22);
mon := Kernel.ThisDetail(obj, S.VAL(Kernel.Type, S.TYP(MONITOR)))(MONITOR);
obj := NIL;
ASSERT(mon # NIL, 23);
mon.cs.ENTER;
IF mon.locker = Kernel.cThisTask() THEN
mon.cs.LEAVE;
HALT(24)
END;
t := tls.Get()(TLS);
t.exclStack[t.sp].object := mon;
S.GET(fp, fp);
S.GET(fp + 4, t.exclStack[t.sp].ret);
INC(t.sp);
S.PUT(fp + 4, S.ADR(RetHookNF));
mon.locker := Kernel.cThisTask()
END EXCLUSIVE;

PROCEDURE UPDATE* ;
VAR inf: Mem.ProcInfo;
ret: INTEGER;
obj: ANYPTR;
mon: MONITOR;
fp, adr: INTEGER;
t: TLS;
BEGIN
S.GETREG(regFp, fp);
S.GET(fp+4, ret);
Mem.GetProcInfo(ret, inf);
ASSERT(Mem.firstStmt IN inf.ext, 20);
ASSERT(Mem.object IN inf.ext, 21);
S.GET(fp, adr);
S.GET(adr + 8, obj);
ASSERT(obj # NIL, 22);
mon := Kernel.ThisDetail(obj, S.VAL(Kernel.Type, S.ADR(MONITOR)))(MONITOR);
obj := NIL;
ASSERT(mon # NIL, 23);
mon.cs.ENTER;
mon.update := TRUE;
IF mon.locker = Kernel.cThisTask() THEN
mon.cs.LEAVE;
HALT(24)
END;
t := tls.Get()(TLS);
t.exclStack[t.sp].object := mon;
S.GET(fp, fp);
S.GET(fp + 4, t.exclStack[t.sp].ret);
INC(t.sp);
S.PUT(fp + 4, S.ADR(RetHookNF));
mon.locker := Kernel.cThisTask()
END UPDATE;

PROCEDURE Exit;
VAR t: TLS;
i: INTEGER;
mon: MONITOR;
BEGIN
t := tls.Get()(TLS);
FOR i := t.sp-1 TO 0 BY -1 DO
mon := t.exclStack[i].object;
mon.locker := -1;
mon.cs.LEAVE
END;
t.sp := 0
END Exit;

(* 20 - wrong caller signature;
21 - call form non-exclusive block
*)

PROCEDURE AWAIT* ;
VAR fp, ret: INTEGER;
inf: Mem.ProcInfo;
obj: ANYPTR;
mon: MONITOR;
await: Await;
t: TLS;
ok: BOOLEAN;
BEGIN
S.GETREG(regFp, fp);
S.GET(fp+4, ret);
Mem.GetProcInfo(ret, inf);
ASSERT(Mem.object IN inf.ext, 21);
S.GET(fp, fp);
S.GET(fp + 8, obj);
ASSERT(obj # NIL, 22);
mon := Kernel.ThisDetail(obj, S.VAL(Kernel.Type, S.ADR(MONITOR)))(MONITOR);
obj := NIL; (* To prevent anchor until wait *)
ASSERT(mon # NIL, 23);
ASSERT(mon.locker = Kernel.cThisTask(), 24);
t := tls.Get()(TLS);
(* IF (awaitOrComplete * t.flags # {}) & Kernel.cShouldComplete(Kernel.cThisTask()) THEN
Exit; Kernel.cCloseTask(Kernel.cThisTask(), ok)
END; *)
await := awaitHeap.Alloc()(Await);
IF mon.end = NIL THEN
mon.await := await
ELSE
mon.end.next := await
END;
mon.end := await;
(* Unlock exclusive section *)
mon.locker := -1;
mon.cs.LEAVE;
await.sem.WAIT;
(* Re-enter exclusive section *)
mon.cs.ENTER;
mon.locker := Kernel.cThisTask();
awaitHeap.Free(await); (* Only after all other awaits signalled, to prevent await.next destroing *)
(* IF (awaitOrComplete * t.flags # {}) & Kernel.cShouldComplete(Kernel.cThisTask()) THEN
Exit; Kernel.cCloseTask(Kernel.cThisTask(), ok)
END *)
END AWAIT;

PROCEDURE TrapChecker;
BEGIN
Exit
END TrapChecker;

PROCEDURE Init;
VAR t: TLS;
await: Await;
BEGIN
NEW(t);
tls := Synch.dir.NewStorage(t);
NEW(await);
NEW(awaitHeap);
awaitHeap.Init(0)
END Init;

BEGIN
Init;
Kernel.InstallTrapGlobalChecker(TrapChecker)
CLOSE
Kernel.RemoveTrapGlobalChecker(TrapChecker)
END Ao.

Резюме: активное ядро и основную "механику" можно считать стабильной. Можно готовить релиз. Предупреждаю, что имена процедур и вообще интерфейс сильно изменится...

В примере с дискетой никто не мешает иметь задачу-супервизор, которая по прошествии этого таймаута принудительно завершает задачу чтения с дискеты.