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
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
|
-- GHDL Run Time (GRT) - processes.
-- Copyright (C) 2002 - 2014 Tristan Gingold
--
-- GHDL is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 2, or (at your option) any later
-- version.
--
-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GCC; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License. This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
with Grt.Table;
with Ada.Unchecked_Deallocation;
with System.Storage_Elements; -- Work around GNAT bug.
pragma Unreferenced (System.Storage_Elements);
with Grt.Disp;
with Grt.Astdio;
with Grt.Astdio.Vhdl; use Grt.Astdio.Vhdl;
with Grt.Errors; use Grt.Errors;
with Grt.Errors_Exec; use Grt.Errors_Exec;
with Grt.Options;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Utils;
with Grt.Hooks;
with Grt.Callbacks; use Grt.Callbacks;
with Grt.Disp_Signals;
with Grt.Stats;
with Grt.Threads; use Grt.Threads;
pragma Elaborate_All (Grt.Table);
package body Grt.Processes is
Last_Time : constant Std_Time := Std_Time'Last;
-- Identifier for a process.
type Process_Id is new Integer;
-- Table of processes.
package Process_Table is new Grt.Table
(Table_Component_Type => Process_Acc,
Table_Index_Type => Process_Id,
Table_Low_Bound => 1,
Table_Initial => 16);
type Finalizer_Type is record
-- Subprogram containing process code.
Subprg : Proc_Acc;
-- Instance (THIS parameter) for the subprogram.
This : Instance_Acc;
end record;
-- List of finalizer.
package Finalizer_Table is new Grt.Table
(Table_Component_Type => Finalizer_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 2);
-- List of processes to be resume at next cycle.
type Process_Acc_Array is array (Natural range <>) of Process_Acc;
type Process_Acc_Array_Acc is access Process_Acc_Array;
Resume_Process_Table : Process_Acc_Array_Acc;
Last_Resume_Process : Natural := 0;
Postponed_Resume_Process_Table : Process_Acc_Array_Acc;
Last_Postponed_Resume_Process : Natural := 0;
-- Number of processes.
Nbr_Postponed_Processes : Natural := 0;
Nbr_Non_Postponed_Processes : Natural := 0;
-- Number of resumed processes.
Nbr_Resumed_Processes : Long_Long_Integer := 0;
-- Earliest time out within non-sensitized processes.
Process_First_Timeout : Std_Time := Last_Time;
Process_Timeout_Chain : Process_Acc := null;
Elab_Process : Process_Acc;
procedure Init is
begin
-- Create a dummy process so that elaboration has a context.
Elab_Process := new Process_Type'(Subprg => null,
This => null,
Rti => Null_Context,
Sensitivity => null,
Stack2 => Null_Stack2_Ptr,
Resumed => False,
Postponed => False,
State => State_Sensitized,
Timeout => Bad_Time,
Timeout_Chain_Next => null,
Timeout_Chain_Prev => null);
Set_Current_Process (Elab_Process);
-- LRM93 12.3 Elaboration of a declarative part
-- During static elaboration, the function STD.STANDARD.NOW (see 14.2)
-- returns the vallue 0 ns.
Current_Time := 0;
end Init;
function Get_Nbr_Processes return Natural is
begin
return Natural (Process_Table.Last);
end Get_Nbr_Processes;
function Get_Nbr_Sensitized_Processes return Natural
is
Res : Natural := 0;
begin
for I in Process_Table.First .. Process_Table.Last loop
if Process_Table.Table (I).State = State_Sensitized then
Res := Res + 1;
end if;
end loop;
return Res;
end Get_Nbr_Sensitized_Processes;
function Get_Nbr_Resumed_Processes return Long_Long_Integer is
begin
return Nbr_Resumed_Processes;
end Get_Nbr_Resumed_Processes;
function Get_Rti_Context (Proc : Process_Acc) return Rti_Context is
begin
return Proc.Rti;
end Get_Rti_Context;
procedure Process_Register (This : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Rti_Context;
State : Process_State;
Postponed : Boolean)
is
P : Process_Acc;
begin
P := new Process_Type'(Subprg => Proc,
This => This,
Rti => Ctxt,
Sensitivity => null,
Stack2 => Null_Stack2_Ptr,
Resumed => False,
Postponed => Postponed,
State => State,
Timeout => Bad_Time,
Timeout_Chain_Next => null,
Timeout_Chain_Prev => null);
Process_Table.Append (P);
-- Used to create drivers.
Set_Current_Process (P);
if Postponed then
Nbr_Postponed_Processes := Nbr_Postponed_Processes + 1;
else
Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1;
end if;
end Process_Register;
procedure Ghdl_Process_Register
(Instance : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Ghdl_Rti_Access;
Addr : System.Address)
is
begin
Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, False);
end Ghdl_Process_Register;
procedure Ghdl_Sensitized_Process_Register
(Instance : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Ghdl_Rti_Access;
Addr : System.Address)
is
begin
Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, False);
end Ghdl_Sensitized_Process_Register;
procedure Ghdl_Postponed_Process_Register
(Instance : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Ghdl_Rti_Access;
Addr : System.Address)
is
begin
Process_Register (Instance, Proc, (Addr, Ctxt), State_Ready, True);
end Ghdl_Postponed_Process_Register;
procedure Ghdl_Postponed_Sensitized_Process_Register
(Instance : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Ghdl_Rti_Access;
Addr : System.Address)
is
begin
Process_Register (Instance, Proc, (Addr, Ctxt), State_Sensitized, True);
end Ghdl_Postponed_Sensitized_Process_Register;
procedure Verilog_Process_Register (This : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Rti_Context)
is
P : Process_Acc;
begin
P := new Process_Type'(Rti => Ctxt,
Sensitivity => null,
Resumed => False,
Postponed => False,
State => State_Sensitized,
Stack2 => Null_Stack2_Ptr,
Timeout => Bad_Time,
Timeout_Chain_Next => null,
Timeout_Chain_Prev => null,
Subprg => Proc,
This => This);
Process_Table.Append (P);
Nbr_Non_Postponed_Processes := Nbr_Non_Postponed_Processes + 1;
-- Used to create drivers.
Set_Current_Process (P);
end Verilog_Process_Register;
procedure Ghdl_Initial_Register (Instance : Instance_Acc;
Proc : Proc_Acc)
is
begin
Verilog_Process_Register (Instance, Proc, Null_Context);
end Ghdl_Initial_Register;
procedure Ghdl_Always_Register (Instance : Instance_Acc;
Proc : Proc_Acc)
is
begin
Verilog_Process_Register (Instance, Proc, Null_Context);
end Ghdl_Always_Register;
function Ghdl_Register_Foreign_Process
(Instance : Instance_Acc; Proc : Proc_Acc) return Process_Acc is
begin
Verilog_Process_Register (Instance, Proc, Null_Context);
return Get_Current_Process;
end Ghdl_Register_Foreign_Process;
procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
is
begin
Resume_Process_If_Event
(Sig, Process_Table.Table (Process_Table.Last));
end Ghdl_Process_Add_Sensitivity;
procedure Ghdl_Finalize_Register (Instance : Instance_Acc;
Proc : Proc_Acc)
is
begin
Finalizer_Table.Append (Finalizer_Type'(Proc, Instance));
end Ghdl_Finalize_Register;
procedure Call_Finalizers is
El : Finalizer_Type;
begin
for I in Finalizer_Table.First .. Finalizer_Table.Last loop
El := Finalizer_Table.Table (I);
El.Subprg.all (El.This);
end loop;
end Call_Finalizers;
procedure Resume_Process (Proc : Process_Acc)
is
begin
if not Proc.Resumed then
Proc.Resumed := True;
if Proc.Postponed then
Last_Postponed_Resume_Process := Last_Postponed_Resume_Process + 1;
Postponed_Resume_Process_Table (Last_Postponed_Resume_Process)
:= Proc;
else
Last_Resume_Process := Last_Resume_Process + 1;
Resume_Process_Table (Last_Resume_Process) := Proc;
end if;
end if;
end Resume_Process;
function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type)
return System.Address
is
Proc : constant Process_Acc := Get_Current_Process;
begin
return Grt.Stack2.Allocate (Proc.Stack2, Size);
end Ghdl_Stack2_Allocate;
function Ghdl_Stack2_Mark return Mark_Id
is
Proc : constant Process_Acc := Get_Current_Process;
St2 : Stack2_Ptr;
begin
St2 := Proc.Stack2;
-- Check that stack2 has been created. This check is done only here,
-- because Mark is called before Release (obviously) but also before
-- Allocate.
if St2 = Null_Stack2_Ptr then
if Proc.State = State_Sensitized then
-- Sensitized processes share the stack2, as the stack2 is empty
-- when sensitized processes suspend.
St2 := Get_Common_Stack2;
else
St2 := Grt.Stack2.Create;
end if;
Proc.Stack2 := St2;
end if;
return Grt.Stack2.Mark (St2);
end Ghdl_Stack2_Mark;
procedure Ghdl_Stack2_Release (Mark : Mark_Id)
is
Proc : constant Process_Acc := Get_Current_Process;
begin
Grt.Stack2.Release (Proc.Stack2, Mark);
end Ghdl_Stack2_Release;
procedure Free is new Ada.Unchecked_Deallocation
(Action_List, Action_List_Acc);
-- List of unused action_list to be recycled.
Old_Action_List : Action_List_Acc;
procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
is
Proc : constant Process_Acc := Get_Current_Process;
El : Action_List_Acc;
begin
-- Allocate a structure.
if Old_Action_List = null then
El := new Action_List (Dynamic => True);
else
El := Old_Action_List;
Old_Action_List := El.Next;
pragma Assert (El.Dynamic);
end if;
El.all := Action_List'(Dynamic => True,
Next => Sig.Event_List,
Proc => Proc,
Prev => null,
Sig => Sig,
Chain => Proc.Sensitivity);
-- Put EL on SIG event list.
if Sig.Event_List /= null and then Sig.Event_List.Dynamic then
Sig.Event_List.Prev := El;
end if;
Sig.Event_List := El;
-- Put EL on PROC sensitivity list.
Proc.Sensitivity := El;
end Ghdl_Process_Wait_Add_Sensitivity;
procedure Update_Process_First_Timeout (Proc : Process_Acc) is
begin
-- Update Process_First_Timeout
if Proc.Timeout < Process_First_Timeout then
Process_First_Timeout := Proc.Timeout;
end if;
-- Append PROC on Process_Timeout_Chain.
Proc.Timeout_Chain_Next := Process_Timeout_Chain;
Proc.Timeout_Chain_Prev := null;
if Process_Timeout_Chain /= null then
Process_Timeout_Chain.Timeout_Chain_Prev := Proc;
end if;
Process_Timeout_Chain := Proc;
end Update_Process_First_Timeout;
procedure Remove_Process_From_Timeout_Chain (Proc : Process_Acc) is
begin
-- Remove Proc from the timeout list.
if Proc.Timeout_Chain_Prev /= null then
Proc.Timeout_Chain_Prev.Timeout_Chain_Next :=
Proc.Timeout_Chain_Next;
elsif Process_Timeout_Chain = Proc then
-- Only if Proc is in the chain.
Process_Timeout_Chain := Proc.Timeout_Chain_Next;
end if;
if Proc.Timeout_Chain_Next /= null then
Proc.Timeout_Chain_Next.Timeout_Chain_Prev :=
Proc.Timeout_Chain_Prev;
Proc.Timeout_Chain_Next := null;
end if;
-- Be sure a second call won't corrupt the chain.
Proc.Timeout_Chain_Prev := null;
end Remove_Process_From_Timeout_Chain;
procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time;
Filename : Ghdl_C_String;
Line : Ghdl_I32)
is
Proc : constant Process_Acc := Get_Current_Process;
begin
if Time < 0 then
-- LRM93 8.1
Error ("negative timeout clause", Filename, Line);
end if;
Proc.Timeout := Current_Time + Time;
Update_Process_First_Timeout (Proc);
end Ghdl_Process_Wait_Set_Timeout;
function Ghdl_Process_Wait_Timed_Out return Boolean
is
Proc : constant Process_Acc := Get_Current_Process;
begin
-- Note: in case of timeout, the timeout is removed when process is
-- woken up.
return Proc.State = State_Timeout;
end Ghdl_Process_Wait_Timed_Out;
procedure Ghdl_Process_Wait_Suspend
is
Proc : constant Process_Acc := Get_Current_Process;
begin
if Proc.State = State_Sensitized then
Error ("wait statement in a sensitized process");
end if;
-- Suspend this process.
Proc.State := State_Wait;
end Ghdl_Process_Wait_Suspend;
procedure Ghdl_Process_Wait_Close
is
Proc : constant Process_Acc := Get_Current_Process;
El : Action_List_Acc;
N_El : Action_List_Acc;
begin
-- Remove the action_list for sensitivity.
El := Proc.Sensitivity;
Proc.Sensitivity := null;
while El /= null loop
pragma Assert (El.Proc = Proc);
pragma Assert (El.Dynamic);
-- Remove EL from signal Event_List.
if El.Prev = null then
-- First element of the list; set list head.
El.Sig.Event_List := El.Next;
else
-- Previous elements must be dynamic ones.
pragma Assert (El.Prev.Dynamic);
El.Prev.Next := El.Next;
end if;
if El.Next /= null and then El.Next.Dynamic then
-- No Prev link in non-dynamic element.
El.Next.Prev := El.Prev;
end if;
N_El := El.Chain;
-- Free element...
if Boolean'(True) then
-- ... by moving it to the recycle list.
El.Next := Old_Action_List;
Old_Action_List := El;
else
-- ... by releasing memory.
Free (El);
end if;
El := N_El;
end loop;
-- Remove Proc from the timeout list.
Remove_Process_From_Timeout_Chain (Proc);
-- This is necessary when the process has been woken-up by an event
-- before the timeout triggers.
if Process_First_Timeout = Proc.Timeout then
-- Remove the timeout.
Proc.Timeout := Bad_Time;
declare
Next_Timeout : Std_Time;
P : Process_Acc;
begin
Next_Timeout := Last_Time;
P := Process_Timeout_Chain;
while P /= null loop
case P.State is
when State_Delayed
| State_Wait =>
if P.Timeout > 0
and then P.Timeout < Next_Timeout
then
Next_Timeout := P.Timeout;
end if;
when others =>
null;
end case;
P := P.Timeout_Chain_Next;
end loop;
Process_First_Timeout := Next_Timeout;
end;
else
-- Remove the timeout.
Proc.Timeout := Bad_Time;
end if;
Proc.State := State_Ready;
end Ghdl_Process_Wait_Close;
procedure Ghdl_Process_Wait_Exit
is
Proc : constant Process_Acc := Get_Current_Process;
begin
if Proc.State = State_Sensitized then
Error ("wait statement in a sensitized process");
end if;
-- Mark this process as dead, in order to kill it.
-- It cannot be killed now, since this code is still in the process.
Proc.State := State_Dead;
end Ghdl_Process_Wait_Exit;
procedure Ghdl_Process_Wait_Timeout (Time : Std_Time;
Filename : Ghdl_C_String;
Line : Ghdl_I32)
is
Proc : constant Process_Acc := Get_Current_Process;
begin
if Proc.State = State_Sensitized then
Error ("wait statement in a sensitized process");
end if;
if Time < 0 then
-- LRM93 8.1
Error ("negative timeout clause", Filename, Line);
end if;
Proc.State := State_Delayed;
if Time <= Std_Time'Last - Current_Time then
Proc.Timeout := Current_Time + Time;
Update_Process_First_Timeout (Proc);
else
-- Delay past the end of the times.
Proc.Timeout := Std_Time'Last;
end if;
end Ghdl_Process_Wait_Timeout;
-- Verilog.
procedure Ghdl_Process_Delay (Del : Ghdl_U32)
is
Proc : constant Process_Acc := Get_Current_Process;
begin
Proc.Timeout := Current_Time + Std_Time (Del);
Proc.State := State_Delayed;
Update_Process_First_Timeout (Proc);
end Ghdl_Process_Delay;
-- Protected object lock.
-- Note: there is no real locks, since the kernel is single threading.
-- Multi lock is allowed, and rules are just checked.
type Object_Lock is record
-- The owner of the lock.
-- Nul_Process_Id means the lock is free.
Process : Process_Acc;
-- Number of times the lock has been acquired.
Count : Natural;
end record;
type Object_Lock_Acc is access Object_Lock;
type Object_Lock_Acc_Acc is access Object_Lock_Acc;
function To_Lock_Acc_Acc is new Ada.Unchecked_Conversion
(Source => System.Address, Target => Object_Lock_Acc_Acc);
procedure Ghdl_Protected_Enter (Obj : System.Address)
is
Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
begin
if Lock.Count = 0 then
-- Protected object not locked.
if Lock.Process /= null then
-- Sanity check failed: count must be 0.
Internal_Error ("protected_enter");
end if;
-- Note: during elaboration, there is no current process.
Lock.Process := Get_Current_Process;
Lock.Count := 1;
else
-- Protected object already locked.
if Lock.Process /= Get_Current_Process then
-- Should be locked by the current process.
Internal_Error ("protected_enter(2)");
end if;
Lock.Count := Lock.Count + 1;
end if;
end Ghdl_Protected_Enter;
procedure Ghdl_Protected_Leave (Obj : System.Address)
is
Lock : constant Object_Lock_Acc := To_Lock_Acc_Acc (Obj).all;
begin
if Lock.Process /= Get_Current_Process then
Internal_Error ("protected_leave(1)");
end if;
if Lock.Count = 0 then
Internal_Error ("protected_leave(2)");
end if;
Lock.Count := Lock.Count - 1;
if Lock.Count = 0 then
Lock.Process := null;
end if;
end Ghdl_Protected_Leave;
procedure Ghdl_Protected_Init (Obj : System.Address)
is
Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
begin
Lock.all := new Object_Lock'(Process => null, Count => 0);
end Ghdl_Protected_Init;
procedure Ghdl_Protected_Fini (Obj : System.Address)
is
procedure Deallocate is new Ada.Unchecked_Deallocation
(Object => Object_Lock, Name => Object_Lock_Acc);
Lock : constant Object_Lock_Acc_Acc := To_Lock_Acc_Acc (Obj);
begin
if Lock.all.Count /= 0 or Lock.all.Process /= null then
Internal_Error ("protected_fini");
end if;
Deallocate (Lock.all);
end Ghdl_Protected_Fini;
function Compute_Next_Time return Std_Time
is
Res : Std_Time;
begin
-- f) The time of the next simulation cycle, Tn, is determined by
-- setting it to the earliest of
-- 1) TIME'HIGH
Res := Std_Time'Last;
-- 3) The next time at which a process resumes.
Res := Std_Time'Min (Res, Process_First_Timeout);
-- LRM08 14.7.5.1 Model execution
-- d) The next time at which a registered and enabled vhpiCbAfterDelay
-- [...] callback is to occur.
Res := Std_Time'Min (Res, Get_First_Time (Hooks.Cb_After_Delay));
if Res = Current_Time then
return Res;
end if;
-- 2) The next time at which a driver becomes active, or [...]
Res := Grt.Signals.Find_Next_Time (Res);
-- Note that Find_Next_Time has a side effect: it updates the
-- active_chain. That's the reason why it is the last.
return Res;
end Compute_Next_Time;
procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc)
is
begin
Grt.Rtis_Utils.Put (Stream, Proc.Rti);
end Disp_Process_Name;
procedure Disp_All_Processes
is
use Grt.Stdio;
use Grt.Astdio;
begin
for I in Process_Table.First .. Process_Table.Last loop
declare
Proc : constant Process_Acc := Process_Table.Table (I);
begin
Disp_Process_Name (stdout, Proc);
New_Line (stdout);
Put (stdout, " State: ");
case Proc.State is
when State_Sensitized =>
Put (stdout, "sensitized");
when State_Wait =>
Put (stdout, "wait");
if Proc.Timeout /= Bad_Time then
Put (stdout, " until ");
Put_Time (stdout, Proc.Timeout);
end if;
when State_Ready =>
Put (stdout, "ready");
when State_Timeout =>
Put (stdout, "timeout");
when State_Delayed =>
Put (stdout, "delayed");
when State_Dead =>
Put (stdout, "dead");
end case;
-- Put (stdout, ": time: ");
-- Put_U64 (stdout, Proc.Stats_Time);
-- Put (stdout, ", runs: ");
-- Put_U32 (stdout, Proc.Stats_Run);
New_Line (stdout);
end;
end loop;
end Disp_All_Processes;
pragma Unreferenced (Disp_All_Processes);
-- Run resumed processes.
-- If POSTPONED is true, resume postponed processes, else resume
-- non-posponed processes.
Mt_Last : Natural;
Mt_Table : Process_Acc_Array_Acc;
Mt_Index : aliased Natural;
procedure Run_Processes_Threads
is
Proc : Process_Acc;
Idx : Natural;
begin
loop
-- Atomically get a process to be executed
Idx := Grt.Threads.Atomic_Inc (Mt_Index'Access);
if Idx > Mt_Last then
return;
end if;
Proc := Mt_Table (Idx);
if Grt.Options.Trace_Processes then
Grt.Astdio.Put ("run process ");
Disp_Process_Name (Stdio.stdout, Proc);
Grt.Astdio.Put (" [");
Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
Grt.Astdio.Put ("]");
Grt.Astdio.New_Line;
end if;
if not Proc.Resumed then
Internal_Error ("run non-resumed process");
end if;
Proc.Resumed := False;
Set_Current_Process (Proc);
Proc.Subprg.all (Proc.This);
if Grt.Options.Checks then
Ghdl_Signal_Internal_Checks;
end if;
end loop;
end Run_Processes_Threads;
function Run_Processes (Postponed : Boolean) return Integer
is
Table : Process_Acc_Array_Acc;
Last : Natural;
begin
if Postponed then
null;
else
Call_Callbacks (Hooks.Cb_Start_Of_Processes);
end if;
if Options.Flag_Stats then
Stats.Start_Processes;
end if;
if Postponed then
Table := Postponed_Resume_Process_Table;
Last := Last_Postponed_Resume_Process;
Last_Postponed_Resume_Process := 0;
else
Table := Resume_Process_Table;
Last := Last_Resume_Process;
Last_Resume_Process := 0;
end if;
Nbr_Resumed_Processes :=
Nbr_Resumed_Processes + Long_Long_Integer (Last);
if Options.Nbr_Threads = 1 then
for I in 1 .. Last loop
declare
Proc : constant Process_Acc := Table (I);
begin
if not Proc.Resumed then
Internal_Error ("run non-resumed process");
end if;
if Grt.Options.Trace_Processes then
Grt.Astdio.Put ("run process ");
Disp_Process_Name (Stdio.stdout, Proc);
Grt.Astdio.Put (" [");
Grt.Astdio.Put (Stdio.stdout, To_Address (Proc.This));
Grt.Astdio.Put ("]");
Grt.Astdio.New_Line;
end if;
Proc.Resumed := False;
Set_Current_Process (Proc);
Proc.Subprg.all (Proc.This);
if Grt.Options.Checks then
Ghdl_Signal_Internal_Checks;
end if;
end;
end loop;
else
Mt_Last := Last;
Mt_Table := Table;
Mt_Index := 1;
Threads.Run_Parallel (Run_Processes_Threads'Access);
end if;
if Last >= 1 then
return Run_Resumed;
else
return Run_None;
end if;
end Run_Processes;
procedure Initialization_Phase
is
Status : Integer;
pragma Unreferenced (Status);
begin
-- Allocate processes arrays.
Resume_Process_Table :=
new Process_Acc_Array (1 .. Nbr_Non_Postponed_Processes);
Postponed_Resume_Process_Table :=
new Process_Acc_Array (1 .. Nbr_Postponed_Processes);
-- LRM93 12.6.4
-- At the beginning of initialization, the current time, Tc, is assumed
-- to be 0 ns.
--
-- GHDL: already initialized before elaboration.
pragma Assert (Current_Time = 0);
-- The initialization phase consists of the following steps:
-- - The driving value and the effective value of each explicitly
-- declared signal are computed, and the current value of the signal
-- is set to the effective value. This value is assumed to have been
-- the value of the signal for an infinite length of time prior to
-- the start of the simulation.
Init_Signals;
-- - The value of each implicit signal of the form S'Stable(T) or
-- S'Quiet(T) is set to true. The value of each implicit signal of
-- the form S'Delayed is set to the initial value of its prefix, S.
-- GHDL: already done when the signals are created.
null;
-- - The value of each implicit GUARD signal is set to the result of
-- evaluating the corresponding guard expression.
null;
for I in Process_Table.First .. Process_Table.Last loop
Resume_Process (Process_Table.Table (I));
end loop;
-- - Each nonpostponed process in the model is executed until it
-- suspends.
Status := Run_Processes (Postponed => False);
-- - Each postponed process in the model is executed until it suspends.
Status := Run_Processes (Postponed => True);
-- - The time of the next simulation cycle (which in this case is the
-- first simulation cycle), Tn, is calculated according to the rules
-- of step f of the simulation cycle, below.
Next_Time := Compute_Next_Time;
if Next_Time /= 0 then
if Has_Callbacks (Hooks.Cb_Last_Known_Delta) then
Call_Callbacks (Hooks.Cb_Last_Known_Delta);
Flush_Active_Chain;
Next_Time := Compute_Next_Time;
end if;
end if;
-- Clear current_delta, will be set by Simulation_Cycle.
Current_Delta := 0;
end Initialization_Phase;
-- Launch a simulation cycle.
function Simulation_Cycle return Integer
is
Tn : Std_Time;
Status : Integer;
begin
-- LRM08 14.7.5.3 Simulation cycle (ex LRM93 12.6.4)
-- A simulation cycle consists of the following steps:
--
-- a) The current time, Tc is set equal to Tn. Simulation is complete
-- when Tn = TIME'HIGH and there are no active drivers or process
-- resumptions at Tn.
-- GHDL: the check is done at the last step of the cycle.
Current_Time := Next_Time;
if Grt.Options.Disp_Time then
Grt.Disp.Disp_Now;
end if;
-- b) The following actions occur in the indicated order:
-- 1) If the current simulation cycle is not a delta cycle, each
-- registered and enabled vhpiCbNextTimeStep and
-- vhpiCbRepNextTimeStep callback is executed [TODO]
if Current_Delta = 0 then
Call_Callbacks (Hooks.Cb_Next_Time_Step);
end if;
-- 2) Each registered and enabled vhpiCbStartOfNextCycle and
-- vhpiCbRepStartOfNextCycle callback is executed [TODO]
-- 3) Each registered and enabled vhpiCbAfterDelay and
-- vhpiCbRepAfterDelay callback is executed.
if Current_Time = Get_First_Time (Hooks.Cb_After_Delay) then
Call_Time_Callbacks (Hooks.Cb_After_Delay);
if Options.Break_Simulation then
return Run_Stop;
end if;
end if;
-- c) Each active driver in the model is updated. If a force or deposit
-- was scheduled for any driver, the force or deposit is no longer
-- scheduler for the driver [TODO]
-- d) Each signal on each net in the model that includes active drivers
-- is updated in an order that is consistent with the dependency
-- relaction between signals (see 14.7.4). (Events may occur on
-- signals as a results.) If a force, deposit, or release was
-- scheduled for any signal, the force, deposit, or release is no
-- longer scheduled for the signal.
if Options.Flag_Stats then
Stats.Start_Update;
end if;
Update_Signals;
Call_Callbacks (Hooks.Cb_Signals_Updated);
if Options.Flag_Stats then
Stats.Start_Resume;
end if;
-- e) Any action required to give effect to a PSL directive is performed
-- [TODO]
null;
-- f) The following actions occur in the indicated order:
-- 2) For each process P, if P is currently sensitive to a signal S
-- and if an event has occurred on S in this simulation cycle,
-- then P resumes.
if Current_Time = Process_First_Timeout then
-- There are processes to awake.
Tn := Last_Time;
declare
Proc : Process_Acc;
Next_Proc : Process_Acc;
begin
Proc := Process_Timeout_Chain;
while Proc /= null loop
Next_Proc := Proc.Timeout_Chain_Next;
case Proc.State is
when State_Sensitized =>
null;
when State_Delayed =>
if Proc.Timeout = Current_Time then
Proc.Timeout := Bad_Time;
Remove_Process_From_Timeout_Chain (Proc);
Resume_Process (Proc);
Proc.State := State_Ready;
elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
Tn := Proc.Timeout;
end if;
when State_Wait =>
if Proc.Timeout = Current_Time then
Proc.Timeout := Bad_Time;
Resume_Process (Proc);
Proc.State := State_Timeout;
elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then
Tn := Proc.Timeout;
end if;
when State_Timeout
| State_Ready =>
Internal_Error ("process in timeout");
when State_Dead =>
null;
end case;
Proc := Next_Proc;
end loop;
end;
Process_First_Timeout := Tn;
end if;
-- 3) For each nonpostponed that has resumed in the current
-- simulation cycle, the following actions occur in the indicated
-- order:
-- - Each registered and enabled vhpiCbResume callback associated
-- with P is executed [TODO]
-- - The processes executes until it suspends.
-- - Each registered and enabled vhpiCbSyspend callback associated
-- with P is executed [TODO]
Status := Run_Processes (Postponed => False);
-- g) The time of the next simulation cycle, Tn, is calculated according
-- to the rules of 14.7.5.1
if Options.Flag_Stats then
Stats.Start_Next_Time;
end if;
Tn := Compute_Next_Time;
-- h) If the next simulation cycle will be a delta cycle, the remainder
-- of the step is skipped. Otherwise the following actions occur
-- in the indicated order:
-- 1) Each registered and enabled vhpiLastKnownDeltaCycle and
-- vhpiCbRepLastKnownDeltaCycle callback is executed. Tn is
-- recalculated according to the rules of 14.7.5.1
-- [...]
-- 4) For each postponed process P, if P has resumed but has not been
-- executed since its last resumption, the following actions occur
-- in the indicated order:
-- - Each registered and enabled vhpiCbResume callback associated
-- with P is executed [TODO]
-- - The process executes until it suspends.
-- - Each registered and enabled vhpiCbSuspend callback associated
-- with P is executed [TODO]
-- 5) Tn is recalculated according to the rules of 14.7.5.1
-- 6) [TODO]
-- 7) If Tn = TIME'HIGH and there are no active drivers, process
-- resumptions, or registered and enabled vhpiCbAfterDelay,
-- vhpiCbRepAfterDelay, vhpiCbTimeOut, or VhpiCbRepTimeOut
-- callbacks to occur at Tn, then each registered and enabled
-- vhpiCbQuiescence is executed. [TODO]
-- Tn is recalculated according to the rules of 14.7.5.1
-- It is an error if the execution of any postponed process or any
-- callback executed in substeps 3) through 7) of step h) causes a
-- delta cycle to occur immediatly after the current simulation
-- cycle.
if Tn /= Current_Time then
if Has_Callbacks (Hooks.Cb_Last_Known_Delta) then
Call_Callbacks (Hooks.Cb_Last_Known_Delta);
Flush_Active_Chain;
Tn := Compute_Next_Time;
end if;
end if;
if Tn /= Current_Time then
if Last_Postponed_Resume_Process /= 0 then
Flush_Active_Chain;
Status := Run_Processes (Postponed => True);
if Options.Flag_Stats then
Stats.Start_Next_Time;
end if;
Tn := Compute_Next_Time;
if Tn = Current_Time then
Error ("postponed process causes a delta cycle");
end if;
end if;
if Has_Callbacks (Hooks.Cb_End_Of_Time_Step) then
Call_Callbacks (Hooks.Cb_End_Of_Time_Step);
Tn := Compute_Next_Time;
end if;
Next_Time := Tn;
Current_Delta := 0;
-- Statistics.
Nbr_Cycles := Nbr_Cycles + 1;
-- For wave dumpers.
Grt.Hooks.Call_Cycle_Hooks;
return Run_Resumed;
end if;
if Current_Time = Last_Time and then Status = Run_None then
-- End of time and no process to run.
return Run_Finished;
else
Current_Delta := Current_Delta + 1;
-- Statistics.
Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1;
return Run_Resumed;
end if;
end Simulation_Cycle;
function Simulation_Init return Integer
is
use Options;
begin
if Flag_Stats then
Stats.Start_Order;
end if;
Grt.Hooks.Call_Start_Hooks;
Grt.Signals.Order_All_Signals;
if Grt.Options.Disp_Signals_Map then
Grt.Disp_Signals.Disp_Signals_Map;
end if;
if Grt.Options.Disp_Signals_Table then
Grt.Disp_Signals.Disp_Signals_Table;
end if;
if Disp_Signals_Order then
Grt.Disp.Disp_Signals_Order;
end if;
if Disp_Sensitivity then
Grt.Disp_Signals.Disp_All_Sensitivity;
end if;
if Nbr_Threads /= 1 then
Threads.Init;
end if;
-- if Disp_Sig_Types then
-- Grt.Disp.Disp_Signals_Type;
-- end if;
Initialization_Phase;
Nbr_Delta_Cycles := 0;
Nbr_Cycles := 0;
if Trace_Signals then
Grt.Disp_Signals.Disp_All_Signals;
end if;
if Next_Time /= 0 then
-- This is the end of a cycle. This can happen when the time is not
-- zero after initialization.
Grt.Hooks.Call_Cycle_Hooks;
end if;
return 0;
end Simulation_Init;
function Has_Simulation_Timeout return Boolean
is
use Options;
begin
if Next_Time > Stop_Time
and then Next_Time /= Std_Time'Last
then
-- FIXME: Implement with a callback instead ? This could be done
-- in 2 steps: an after_delay for the time and then a read_only
-- to finish the current cycle. Note that no message should be
-- printed if the simulation is already finished at the stop time.
Info_S ("simulation stopped by --stop-time @");
Diag_C_Now;
Info_E;
return True;
elsif Current_Delta >= Stop_Delta then
Info_S ("simulation stopped @");
Diag_C_Now;
Diag_C (" by --stop-delta=");
Diag_C (Stop_Delta);
Info_E;
return True;
else
return False;
end if;
end Has_Simulation_Timeout;
function Simulation_Step return Integer
is
use Options;
Status : Integer;
begin
Status := Simulation_Cycle;
-- Simulation has been stopped/finished by vpi.
if Status = Run_Stop then
return 2;
end if;
if Trace_Signals then
Grt.Disp_Signals.Disp_All_Signals;
end if;
-- Simulation is finished.
if Status = Run_Finished then
return 3;
end if;
-- Simulation is stopped by user timeout.
if Has_Simulation_Timeout then
return 4;
end if;
if Current_Delta = 0 then
Grt.Hooks.Call_Cycle_Hooks;
return 1;
else
if Current_Delta >= Stop_Delta then
return 5;
else
return 0;
end if;
end if;
end Simulation_Step;
function Simulation_Main_Loop return Integer
is
use Options;
Status : Integer;
begin
loop
Status := Simulation_Cycle;
-- Simulation has been stopped/finished by vpi.
exit when Status = Run_Stop;
if Trace_Signals then
Grt.Disp_Signals.Disp_All_Signals;
end if;
-- Simulation is finished.
exit when Status = Run_Finished;
-- Simulation is stopped by user timeout.
if Has_Simulation_Timeout then
Status := Run_Limit;
exit;
end if;
end loop;
return Status;
end Simulation_Main_Loop;
procedure Simulation_Finish
is
use Options;
begin
if Nbr_Threads /= 1 then
Threads.Finish;
end if;
Call_Finalizers;
end Simulation_Finish;
function Simulation return Integer
is
Status : Integer;
begin
Status := Simulation_Init;
pragma Assert (Status = 0);
Status := Simulation_Main_Loop;
Simulation_Finish;
return Status;
end Simulation;
end Grt.Processes;
|