1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190 | -------------------------------------------------------------------------------------
--
-- HAC - HAC Ada Compiler
--
-- A compiler in Ada for an Ada subset
--
-- Copyright, license, etc. : see top package.
--
-------------------------------------------------------------------------------------
--
-- In_Defs: Internal Interpreter Definitions
with HAC_Sys.Co_Defs, HAC_Sys.Defs;
with Ada.Calendar,
Ada.Containers.Vectors,
Ada.Numerics.Float_Random,
Ada.Unchecked_Deallocation;
package HAC_Sys.PCode.Interpreter.In_Defs is
NilTask : constant := -1;
subtype TRange is Integer range 0 .. Defs.TaskMax; -- task index
type Processor_State is (
Running, -- Normal processor state
Exception_Raised,
--
FIN,
DEADLOCK,
WAIT);
subtype Running_or_in_Exception is Processor_State range Running .. Exception_Raised;
type Task_State is (
-- SmallAda tasking stuff, not tested yet:
Completed,
Delayed,
Ready,
-- HAC is currently tested on this:
Running,
Exception_Raised,
-- SmallAda tasking stuff, not tested yet:
Critical,
WaitRendzv,
WaitSem,
TimedRendz,
TimedWait,
Terminated);
type PriCB is record -- Priority Control Block
UPRI : Integer; -- User specified priority
INHERIT : Boolean; -- Priority inheritance enabled
end record;
type File_Ptr is access Ada.Text_IO.File_Type;
Abstract_Console : constant File_Ptr := null;
type General_Register (Special : Defs.Typen := Defs.NOTYP) is record
-- I is used for most uses: indices in the stack, Integers, Bools, Chars and Enums.
I : Defs.HAC_Integer;
case Special is -- This part is variant to save place.
when Defs.Floats => R : Defs.HAC_Float;
when Defs.VStrings => V : HAT.VString;
when Defs.Times => Tim : Ada.Calendar.Time;
when Defs.Durations => Dur : Duration;
when Defs.Text_Files => Txt : File_Ptr := Abstract_Console;
when others => null;
end case;
end record;
GR_Abstract_Console : constant General_Register :=
(Special => Defs.Text_Files,
I => 0,
Txt => Abstract_Console);
function GR_Real (R : Defs.HAC_Float) return General_Register;
function GR_Time (T : Ada.Calendar.Time) return General_Register;
function GR_Duration (D : Duration) return General_Register;
function GR_VString (S : String) return General_Register;
function GR_VString (V : HAT.VString) return General_Register;
subtype Data_Type is General_Register;
type Stack_Type is array (1 .. Defs.StMax) of Data_Type;
type Stack_Type_Access is access Stack_Type;
type Task_Control_Block is record
T : Defs.Index; -- index of current top of stack
B : Defs.Index; -- index of current base of stack
PC : Defs.Index; -- program counter, next pcode
TS : Task_State; -- current task state
InRendzv : Integer; -- task in rendz with or -1
WAKETIME : Ada.Calendar.Time; -- end of delay period
Pcontrol : PriCB; -- task priority parameter rec.
QUANTUM : Duration; -- time slice
LASTRUN : Ada.Calendar.Time; -- time last run end (fairness)
DISPLAY : Co_Defs.Display_Type; -- Stack base index per nesting level,
-- used for addressing variables.
STACKSIZE : Defs.Index; -- Stack overflow is raised if exceeded.
SUSPEND : Integer; -- id of object suspended on
R1, R2, R3 : General_Register;
R_Temp : General_Register;
Exception_Info : Exception_Propagation_Data;
end record;
type Enode;
type Eptr is access Enode; -- task entry rendzv pointer
type Enode is record -- task entry structure
Task_Index : TRange; -- index of task enqueued for rendzv
Next : Eptr; -- next entry in list
end record;
procedure Dispose is new Ada.Unchecked_Deallocation (Enode, Eptr);
type EHeader is record
Task_Index : TRange; -- index of task that contains entry
First : Eptr; -- ptr to first node in rendzv queue
Last : Eptr; -- ptr to last node in rendzv queue
end record;
type Entry_Queue is array (1 .. Defs.entry_table_max) of EHeader;
package File_Vectors is new Ada.Containers.Vectors (Positive, File_Ptr);
type Task_Control_Blocks is array (TRange) of Task_Control_Block;
Single_Task : constant := -1;
subtype Scheduler_Type is Integer range Single_Task .. 6;
type Tick_Type is mod 128;
-- Objects of type Interpreter_Data contains data that may be useful
-- to be kept post-mortem, or in a snapshot toward the "outside", or
-- passed to the scheduler.
type Interpreter_Data is record
S : Stack_Type_Access;
PS : Processor_State; -- Processor status register
IR : Order; -- Instruction register
CurTask : Integer; -- Index of currently executing task
TCB : Task_Control_Blocks;
Files : File_Vectors.Vector;
Snap : Boolean; -- Snapshot flag to display scheduler status
Nb_Callers : Integer; -- AVL TERMINATE
Nb_Complete : Integer; -- AVL TERMINATE
EList : Entry_Queue;
TActive : TRange; -- no. of active tasks
Start_Time : Ada.Calendar.Time;
SWITCH : Boolean; -- invoke scheduler on next cycle flag
SYSCLOCK : Ada.Calendar.Time; -- (ms after 00:00:00 Jan 1, current year)
TIMER : Ada.Calendar.Time; -- set to end of current task's time slice
Gen : Ada.Numerics.Float_Random.Generator;
Scheduler : Scheduler_Type := Single_Task;
Single_Task_Delay_Pending : Boolean := False;
Instr_Tick : Tick_Type;
end record;
procedure Allocate_Text_File (
ND : in out Interpreter_Data;
R : in out General_Register
);
procedure Free_Allocated_Contents (
ND : in out Interpreter_Data;
Open_Files : out Open_Files_Vectors.Vector
);
-- We have an "array of Character" (cf Is_Char_Array) on the stack
function Get_String_from_Stack (ND : Interpreter_Data; Idx, Size : Integer) return String;
procedure Pop (ND : in out Interpreter_Data; Amount : Positive := 1);
pragma Inline (Pop);
procedure Push (ND : in out Interpreter_Data; Amount : Positive := 1);
pragma Inline (Push);
-- Post Mortem Dump of the task stack causing the exception
--
procedure Post_Mortem_Dump (CD : Co_Defs.Compiler_Data; ND : In_Defs.Interpreter_Data);
procedure Check_Discriminant_Type (X : General_Register; Y : Defs.Typen);
pragma Inline (Check_Discriminant_Type);
end HAC_Sys.PCode.Interpreter.In_Defs;
|