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
|
-- 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_Conversion;
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.Errors; use Grt.Errors;
with Grt.Options;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Utils;
with Grt.Hooks;
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 postponed processes.
Nbr_Postponed_Processes : Natural := 0;
Nbr_Non_Postponed_Processes : Natural := 0;
-- Number of resumed processes.
Nbr_Resumed_Processes : Natural := 0;
-- Earliest time out within non-sensitized processes.
Process_First_Timeout : Std_Time := Last_Time;
Process_Timeout_Chain : Process_Acc := null;
procedure Init is
begin
null;
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 Natural is
begin
return Nbr_Resumed_Processes;
end Get_Nbr_Resumed_Processes;
procedure Process_Register (This : Instance_Acc;
Proc : Proc_Acc;
Ctxt : Rti_Context;
State : Process_State;
Postponed : Boolean)
is
Stack : Stack_Type;
P : Process_Acc;
begin
if State /= State_Sensitized and then not One_Stack then
Stack := Stack_Create (Proc, This);
if Stack = Null_Stack then
Internal_Error ("cannot allocate stack: memory exhausted");
end if;
else
Stack := Null_Stack;
end if;
P := new Process_Type'(Subprg => Proc,
This => This,
Rti => Ctxt,
Sensitivity => null,
Resumed => False,
Postponed => Postponed,
State => State,
Timeout => Bad_Time,
Timeout_Chain_Next => null,
Timeout_Chain_Prev => null,
Stack => Stack);
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,
Timeout => Bad_Time,
Timeout_Chain_Next => null,
Timeout_Chain_Prev => null,
Subprg => Proc,
This => This,
Stack => Null_Stack);
Process_Table.Append (P);
-- 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;
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
begin
return Grt.Stack2.Allocate (Get_Stack2, Size);
end Ghdl_Stack2_Allocate;
function Ghdl_Stack2_Mark return Mark_Id
is
St2 : Stack2_Ptr := Get_Stack2;
begin
if St2 = Null_Stack2_Ptr then
St2 := Grt.Stack2.Create;
Set_Stack2 (St2);
end if;
return Grt.Stack2.Mark (St2);
end Ghdl_Stack2_Mark;
procedure Ghdl_Stack2_Release (Mark : Mark_Id) is
begin
Grt.Stack2.Release (Get_Stack2, Mark);
end Ghdl_Stack2_Release;
procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr)
is
Proc : constant Process_Acc := Get_Current_Process;
El : Action_List_Acc;
begin
El := new 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)
is
Proc : constant Process_Acc := Get_Current_Process;
begin
if Time < 0 then
-- LRM93 8.1
Error ("negative timeout clause");
end if;
Proc.Timeout := Current_Time + Time;
Update_Process_First_Timeout (Proc);
end Ghdl_Process_Wait_Set_Timeout;
function Ghdl_Process_Wait_Has_Timeout 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_Has_Timeout;
procedure Ghdl_Process_Wait_Wait
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;
-- if Cur_Proc.Timeout = Bad_Time then
-- Cur_Proc.Timeout := Std_Time'Last;
-- end if;
end Ghdl_Process_Wait_Wait;
function Ghdl_Process_Wait_Suspend return Boolean
is
Proc : constant Process_Acc := Get_Current_Process;
begin
Ghdl_Process_Wait_Wait;
if One_Stack then
Internal_Error ("wait_suspend");
else
Stack_Switch (Get_Main_Stack, Proc.Stack);
end if;
return Ghdl_Process_Wait_Has_Timeout;
end Ghdl_Process_Wait_Suspend;
procedure Free is new Ada.Unchecked_Deallocation
(Action_List, Action_List_Acc);
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 sensitivity.
El := Proc.Sensitivity;
Proc.Sensitivity := null;
while El /= null loop
pragma Assert (El.Proc = Get_Current_Process);
if El.Prev = null then
El.Sig.Event_List := El.Next;
else
pragma Assert (El.Prev.Dynamic);
El.Prev.Next := El.Next;
end if;
if El.Next /= null and then El.Next.Dynamic then
El.Next.Prev := El.Prev;
end if;
N_El := El.Chain;
Free (El);
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;
-- Suspend this process.
if not One_Stack then
Stack_Switch (Get_Main_Stack, Proc.Stack);
end if;
end Ghdl_Process_Wait_Exit;
procedure Ghdl_Process_Wait_Timeout (Time : Std_Time)
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");
end if;
Proc.Timeout := Current_Time + Time;
Proc.State := State_Wait;
Update_Process_First_Timeout (Proc);
-- Suspend this process.
if One_Stack then
Internal_Error ("wait_timeout");
else
Stack_Switch (Get_Main_Stack, Proc.Stack);
end if;
-- Clean-up.
Proc.Timeout := Bad_Time;
Remove_Process_From_Timeout_Chain (Proc);
Proc.State := State_Ready;
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.Process = null then
if Lock.Count /= 0 then
Internal_Error ("protected_enter");
end if;
Lock.Process := Get_Current_Process;
Lock.Count := 1;
else
if Lock.Process /= Get_Current_Process then
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;
-- 2) The next time at which a driver becomes active, or
Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time);
if Res = Current_Time then
return Res;
end if;
-- 3) The next time at which a process resumes.
if Process_First_Timeout < Res then
-- No signals to be updated.
Grt.Signals.Flush_Active_List;
Res := Process_First_Timeout;
end if;
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.
-- Returns one of these values:
-- No process has been run.
Run_None : constant Integer := 1;
-- At least one process was run.
Run_Resumed : constant Integer := 2;
-- Simulation is finished.
Run_Finished : constant Integer := 3;
-- Failure, simulation should stop.
Run_Failure : constant Integer := -1;
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);
if Proc.State = State_Sensitized or else One_Stack then
Proc.Subprg.all (Proc.This);
else
Stack_Switch (Proc.Stack, Get_Main_Stack);
end if;
if Grt.Options.Checks then
Ghdl_Signal_Internal_Checks;
Grt.Stack2.Check_Empty (Get_Stack2);
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 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 + 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);
if Proc.State = State_Sensitized or else One_Stack then
Proc.Subprg.all (Proc.This);
else
Stack_Switch (Proc.Stack, Get_Main_Stack);
end if;
if Grt.Options.Checks then
Ghdl_Signal_Internal_Checks;
Grt.Stack2.Check_Empty (Get_Stack2);
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;
function Initialization_Phase return Integer
is
Status : Integer;
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.
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);
if Status = Run_Failure then
return Run_Failure;
end if;
-- - Each postponed process in the model is executed until it suspends.
Status := Run_Processes (Postponed => True);
if Status = Run_Failure then
return Run_Failure;
end if;
-- - 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.
Current_Time := Compute_Next_Time;
-- Clear current_delta, will be set by Simulation_Cycle.
Current_Delta := 0;
return Run_Resumed;
end Initialization_Phase;
-- Launch a simulation cycle.
-- Set FINISHED to true if this is the last cycle.
function Simulation_Cycle return Integer
is
Tn : Std_Time;
Status : Integer;
begin
-- 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: this is done at the last step of the cycle.
null;
-- b) Each active explicit signal in the model is updated. (Events
-- may occur on signals as a result).
-- c) Each implicit signal in the model is updated. (Events may occur
-- on signals as a result.)
if Options.Flag_Stats then
Stats.Start_Update;
end if;
Update_Signals;
if Options.Flag_Stats then
Stats.Start_Resume;
end if;
-- d) For each process P, if P is currently sensitive to a signal S and
-- if an event has occured on S in this simulation cycle, then P
-- resumes.
if Current_Time = Process_First_Timeout then
Tn := Last_Time;
declare
Proc : Process_Acc;
begin
Proc := Process_Timeout_Chain;
while Proc /= null loop
case Proc.State is
when State_Sensitized =>
null;
when State_Delayed =>
if Proc.Timeout = Current_Time then
Proc.Timeout := Bad_Time;
Resume_Process (Proc);
Proc.State := State_Sensitized;
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 := Proc.Timeout_Chain_Next;
end loop;
end;
Process_First_Timeout := Tn;
end if;
-- e) Each nonpostponed that has resumed in the current simulation cycle
-- is executed until it suspends.
Status := Run_Processes (Postponed => False);
if Status = Run_Failure then
return Run_Failure;
end if;
-- f) The time of the next simulation cycle, Tn, is determined by
-- setting it to the earliest of
-- 1) TIME'HIGH
-- 2) The next time at which a driver becomes active, or
-- 3) The next time at which a process resumes.
-- If Tn = Tc, then the next simulation cycle (if any) will be a
-- delta cycle.
if Options.Flag_Stats then
Stats.Start_Next_Time;
end if;
Tn := Compute_Next_Time;
-- g) If the next simulation cycle will be a delta cycle, the remainder
-- of the step is skipped.
-- Otherwise, each postponed process that has resumed but has not
-- been executed since its last resumption is executed until it
-- suspends. Then Tn is recalculated according to the rules of
-- step f. It is an error if the execution of any postponed
-- process causes a delta cycle to occur immediatly after the
-- current simulation cycle.
if Tn = Current_Time then
if Current_Time = Last_Time and then Status = Run_None then
return Run_Finished;
else
Current_Delta := Current_Delta + 1;
return Run_Resumed;
end if;
else
Current_Delta := 0;
if Nbr_Postponed_Processes /= 0 then
Status := Run_Processes (Postponed => True);
end if;
if Status = Run_Resumed then
Flush_Active_List;
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;
elsif Status = Run_Failure then
return Run_Failure;
end if;
Current_Time := Tn;
return Run_Resumed;
end if;
end Simulation_Cycle;
function Simulation return Integer
is
use Options;
Status : Integer;
begin
if Nbr_Threads /= 1 then
Threads.Init;
end if;
-- if Disp_Sig_Types then
-- Grt.Disp.Disp_Signals_Type;
-- end if;
Status := Run_Through_Longjump (Initialization_Phase'Access);
if Status /= Run_Resumed then
return -1;
end if;
Nbr_Delta_Cycles := 0;
Nbr_Cycles := 0;
if Trace_Signals then
Grt.Disp_Signals.Disp_All_Signals;
end if;
if Current_Time /= 0 then
-- This is the end of a cycle. This can happen when the time is not
-- zero after initialization.
Cycle_Time := 0;
Grt.Hooks.Call_Cycle_Hooks;
end if;
loop
Cycle_Time := Current_Time;
if Disp_Time then
Grt.Disp.Disp_Now;
end if;
Status := Run_Through_Longjump (Simulation_Cycle'Access);
exit when Status < 0;
if Trace_Signals then
Grt.Disp_Signals.Disp_All_Signals;
end if;
-- Statistics.
if Current_Delta = 0 then
Nbr_Cycles := Nbr_Cycles + 1;
else
Nbr_Delta_Cycles := Nbr_Delta_Cycles + 1;
end if;
exit when Status = Run_Finished;
if Current_Delta = 0 then
Grt.Hooks.Call_Cycle_Hooks;
end if;
if Current_Delta >= Stop_Delta then
Error ("simulation stopped by --stop-delta");
exit;
end if;
if Current_Time > Stop_Time then
if Current_Time /= Last_Time then
Info ("simulation stopped by --stop-time");
end if;
exit;
end if;
end loop;
if Nbr_Threads /= 1 then
Threads.Finish;
end if;
Call_Finalizers;
Grt.Hooks.Call_Finish_Hooks;
if Status = Run_Failure then
return -1;
else
return Exit_Status ;
end if;
end Simulation;
end Grt.Processes;
|