diff options
Diffstat (limited to 'src/grt')
| -rw-r--r-- | src/grt/Makefile.inc | 101 | ||||
| -rw-r--r-- | src/grt/config/jumps.c | 171 | ||||
| -rw-r--r-- | src/grt/config/math.c | 55 | ||||
| -rw-r--r-- | src/grt/grt-errors.adb | 8 | ||||
| -rw-r--r-- | src/grt/grt-errors.ads | 3 | ||||
| -rw-r--r-- | src/grt/grt-main.adb | 8 | ||||
| -rw-r--r-- | src/grt/grt-main.ads | 7 | ||||
| -rw-r--r-- | src/grt/grt-options.adb | 47 | ||||
| -rw-r--r-- | src/grt/grt-options.ads | 8 | ||||
| -rw-r--r-- | src/grt/grt-processes.adb | 154 | ||||
| -rw-r--r-- | src/grt/grt-processes.ads | 67 | ||||
| -rw-r--r-- | src/grt/grt-stack2.adb | 10 | ||||
| -rw-r--r-- | src/grt/grt-stack2.ads | 35 | ||||
| -rw-r--r-- | src/grt/grt-stacks.adb | 43 | ||||
| -rw-r--r-- | src/grt/grt-stacks.ads | 87 | ||||
| -rw-r--r-- | src/grt/grt-unithread.adb | 25 | ||||
| -rw-r--r-- | src/grt/grt-unithread.ads | 22 |
17 files changed, 402 insertions, 449 deletions
diff --git a/src/grt/Makefile.inc b/src/grt/Makefile.inc index df36894..5b64a54 100644 --- a/src/grt/Makefile.inc +++ b/src/grt/Makefile.inc @@ -45,63 +45,22 @@ endif GRT_ELF_OPTS:=-Wl,--version-script=@/grt.ver -Wl,--export-dynamic # Set target files. -ifeq ($(filter-out i%86 linux,$(arch) $(osys)),) - GRT_TARGET_OBJS=i386.o linux.o times.o - GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out x86_64 linux,$(arch) $(osys)),) - GRT_TARGET_OBJS=amd64.o linux.o times.o - GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out i%86 netbsd,$(arch) $(osys)),) - GRT_TARGET_OBJS=i386.o linux.o times.o - GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out x86_64 netbsd,$(arch) $(osys)),) - GRT_TARGET_OBJS=amd64.o linux.o times.o - GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out i%86 freebsd%,$(arch) $(osys)),) - GRT_TARGET_OBJS=i386.o linux.o times.o - GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) - ADAC=ada -endif -ifeq ($(filter-out x86_64 freebsd% dragonfly%,$(arch) $(osys)),) - GRT_TARGET_OBJS=amd64.o linux.o times.o - GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) - ADAC=ada -endif -ifeq ($(filter-out i%86 darwin%,$(arch) $(osys)),) - GRT_TARGET_OBJS=i386.o linux.o times.o - GRT_EXTRA_LIB= -endif -ifeq ($(filter-out x86_64 darwin%,$(arch) $(osys)),) - GRT_TARGET_OBJS=amd64.o linux.o times.o - GRT_EXTRA_LIB= -endif -ifeq ($(filter-out sparc solaris%,$(arch) $(osys)),) - GRT_TARGET_OBJS=sparc.o linux.o times.o - GRT_EXTRA_LIB=-ldl -lm -endif -ifeq ($(filter-out powerpc linux%,$(arch) $(osys)),) - GRT_TARGET_OBJS=ppc.o linux.o times.o - GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out ia64 linux,$(arch) $(osys)),) - GRT_TARGET_OBJS=ia64.o linux.o times.o - GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) -endif -ifeq ($(filter-out i%86 mingw32,$(arch) $(osys)),) - GRT_TARGET_OBJS=win32.o clock.o -endif -# Doesn't work for unknown reasons. -#ifeq ($(filter-out i%86 cygwin,$(arch) $(osys)),) -# GRT_TARGET_OBJS=win32.o clock.o -#endif -# Fall-back: use a generic implementation based on pthreads. -ifndef GRT_TARGET_OBJS - GRT_TARGET_OBJS=pthread.o times.o - GRT_EXTRA_LIB=-lpthread -ldl -lm +ifeq ($(filter-out mingw32,$(arch) $(osys)),) + GRT_TARGET_OBJS=jumps.o math.o clock.o +else + GRT_TARGET_OBJS=jumps.o times.o + ifeq ($(filter-out linux,$(arch) $(osys)),) + GRT_EXTRA_LIB=-ldl -lm $(GRT_ELF_OPTS) + endif + ifeq ($(filter-out netbsd freebsd% dragonfly%,$(arch) $(osys)),) + GRT_EXTRA_LIB=-lm $(GRT_ELF_OPTS) + endif + ifeq ($(filter-out solaris%,$(arch) $(osys)),) + GRT_EXTRA_LIB=-ldl -lm + endif + ifeq ($(filter-out darwin%,$(arch) $(osys)),) + GRT_EXTRA_LIB= + endif endif GRT_FST_OBJS := fstapi.o lz4.o fastlz.o @@ -148,34 +107,13 @@ run-bind.o: run-bind.adb main.o: $(GRTSRCDIR)/main.adb $(GRT_ADACOMPILE) -i386.o: $(GRTSRCDIR)/config/i386.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -chkstk.o: $(GRTSRCDIR)/config/chkstk.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -sparc.o: $(GRTSRCDIR)/config/sparc.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -ppc.o: $(GRTSRCDIR)/config/ppc.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -ia64.o: $(GRTSRCDIR)/config/ia64.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -amd64.o: $(GRTSRCDIR)/config/amd64.S - $(CC) -c $(GRT_FLAGS) -o $@ $< - -linux.o: $(GRTSRCDIR)/config/linux.c +jumps.o: $(GRTSRCDIR)/config/jumps.c $(CC) -c $(GRT_FLAGS) $(GRT_CFLAGS) -o $@ $< win32.o: $(GRTSRCDIR)/config/win32.c $(CC) -c $(GRT_FLAGS) -o $@ $< -win32thr.o: $(GRTSRCDIR)/config/win32thr.c - $(CC) -c $(GRT_FLAGS) -o $@ $< - -pthread.o: $(GRTSRCDIR)/config/pthread.c +math.o: $(GRTSRCDIR)/config/math.c $(CC) -c $(GRT_FLAGS) -o $@ $< times.o : $(GRTSRCDIR)/config/times.c @@ -202,6 +140,9 @@ lz4.o: $(GRTSRCDIR)/fst/lz4.c fastlz.o: $(GRTSRCDIR)/fst/fastlz.c $(CC) -c $(GRT_FLAGS) -o $@ $< +chkstk.o: $(GRTSRCDIR)/config/chkstk.S + $(CC) -c $(GRT_FLAGS) -o $@ $< + grt-disp-config: @echo "target: $(target)" @echo "targ: $(targ)" diff --git a/src/grt/config/jumps.c b/src/grt/config/jumps.c new file mode 100644 index 0000000..360ea80 --- /dev/null +++ b/src/grt/config/jumps.c @@ -0,0 +1,171 @@ +/* Longjump/Setjump wrapper + Copyright (C) 2002 - 2015 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. +*/ + +#include <stddef.h> +#include <signal.h> +#include <fcntl.h> +#include <sys/ucontext.h> + +/* There is a simple setjmp/longjmp mechanism used to report failures. + We have the choice between 3 mechanisms: + * USE_BUITLIN_SJLJ: gcc builtin setjmp/longjmp, very fast but gcc specific. + * USE__SETJMP: _setjmp/_longjmp + * USE_SETJMP: setjmp/longjmp, slower because signals mask is saved/restored. +*/ + +#if defined (__GNUC__) && !defined (__clang__) +#define USE_BUILTIN_SJLJ +#else +#define USE__SETJMP +#endif +/* #define USE_SETJMP */ + +#ifdef USE_BUILTIN_SJLJ +typedef void *JMP_BUF[5]; +static int sjlj_val; +# define SETJMP(BUF) (__builtin_setjmp (BUF), sjlj_val) +# define LONGJMP(BUF, VAL) \ + do { sjlj_val = (VAL); __builtin_longjmp (BUF, 1); } while (0) +#else +# include <setjmp.h> +typedef jmp_buf JMP_BUF; +# ifdef USE__SETJMP +# define SETJMP _setjmp +# define LONGJMP _longjmp +# elif defined (USE_SETJMP) +# define SETJMP setjmp +# define LONGJMP longjmp +# else +# error "SETJMP/LONGJMP not configued" +# endif +#endif + +static int run_env_en; +static JMP_BUF run_env; + +extern void grt_overflow_error (void); + +#ifdef __APPLE__ +#define NEED_SIGFPE_HANDLER +#endif +#if defined (__linux__) && defined (__i386__) +#define NEED_SIGSEGV_HANDLER +#endif + +#ifdef NEED_SIGFPE_HANDLER +static struct sigaction prev_sigfpe_act; + +/* Handler for SIGFPE signal, raised in case of overflow (i386). */ +static void grt_overflow_handler (int signo, siginfo_t *info, void *ptr) +{ + grt_overflow_error (); +} +#endif + +#ifdef NEED_SIGSEGV_HANDLER +static struct sigaction prev_sigsegv_act; + +/* Linux handler for overflow. This is used only by mcode. */ +static void grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr) +{ +#if defined (__linux__) && defined (__i386__) + /* Linux generates a SIGSEGV (!) for an overflow exception. */ + if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4) + { + grt_overflow_error (); + } +#endif + + /* We loose. */ +} +#endif /* __linux__ && __i386__ */ + +static void grt_signal_setup (void) +{ +#ifdef NEED_SIGSEGV_HANDLER + { + struct sigaction sigsegv_act; + + sigsegv_act.sa_sigaction = &grt_sigsegv_handler; + sigemptyset (&sigsegv_act.sa_mask); + sigsegv_act.sa_flags = SA_ONSTACK | SA_SIGINFO; +#ifdef SA_ONESHOT + sigsegv_act.sa_flags |= SA_ONESHOT; +#elif defined (SA_RESETHAND) + sigsegv_act.sa_flags |= SA_RESETHAND; +#endif + + /* We don't care about the return status. + If the handler is not installed, then some feature are lost. */ + sigaction (SIGSEGV, &sigsegv_act, &prev_sigsegv_act); + } +#endif + +#ifdef NEED_SIGFPE_HANDLER + { + struct sigaction sig_ovf_act; + + sig_ovf_act.sa_sigaction = &grt_overflow_handler; + sigemptyset (&sig_ovf_act.sa_mask); + sig_ovf_act.sa_flags = SA_SIGINFO; + + sigaction (SIGFPE, &sig_ovf_act, &prev_sigfpe_act); + } +#endif +} + +static void grt_signal_restore (void) +{ +#ifdef NEED_SIGSEGV_HANDLER + sigaction (SIGSEGV, &prev_sigsegv_act, NULL); +#endif + +#ifdef NEED_SIGFPE_HANDLER + sigaction (SIGFPE, &prev_sigfpe_act, NULL); +#endif +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (run_env_en) + LONGJMP (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + grt_signal_setup (); + res = SETJMP (run_env); + if (res == 0) + res = (*func)(); + grt_signal_restore (); + run_env_en = 0; + return res; +} diff --git a/src/grt/config/math.c b/src/grt/config/math.c new file mode 100644 index 0000000..704225f --- /dev/null +++ b/src/grt/config/math.c @@ -0,0 +1,55 @@ +/* Math routines for Win32 + Copyright (C) 2005 - 2015 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. +*/ + +#include <math.h> + +double acosh (double x) +{ + return log (x + sqrt (x*x - 1)); +} + +double asinh (double x) +{ + return log (x + sqrt (x*x + 1)); +} + +double atanh (double x) +{ + return log ((1 + x) / (1 - x)) / 2; +} + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb index ed93668..29da112 100644 --- a/src/grt/grt-errors.adb +++ b/src/grt/grt-errors.adb @@ -238,6 +238,14 @@ package body Grt.Errors is Newline_Err; end Info; + procedure Warning (Str : String) is + begin + Put_Err (Progname); + Put_Err (":warning: "); + Put_Err (Str); + Newline_Err; + end Warning; + procedure Internal_Error (Msg : String) is begin Put_Err (Progname); diff --git a/src/grt/grt-errors.ads b/src/grt/grt-errors.ads index 33c9932..8dcf55b 100644 --- a/src/grt/grt-errors.ads +++ b/src/grt/grt-errors.ads @@ -51,6 +51,9 @@ package Grt.Errors is -- Complete error message. procedure Error (Str : String); + -- Warning message. + procedure Warning (Str : String); + -- Internal error. The message must contain the subprogram name which -- has called this procedure. procedure Internal_Error (Msg : String); diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb index 4d4106b..5d825de 100644 --- a/src/grt/grt-main.adb +++ b/src/grt/grt-main.adb @@ -26,7 +26,6 @@ with System.Storage_Elements; -- Work around GNAT bug. pragma Unreferenced (System.Storage_Elements); with Grt.Types; use Grt.Types; with Grt.Errors; -with Grt.Stacks; with Grt.Processes; with Grt.Signals; with Grt.Options; use Grt.Options; @@ -133,8 +132,6 @@ package body Grt.Main is end if; -- Internal initializations. - Grt.Stacks.Stack_Init; - Grt.Hooks.Call_Init_Hooks; Grt.Processes.Init; @@ -146,8 +143,7 @@ package body Grt.Main is end if; -- Elaboration. Run through longjump to catch errors. - if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0 - then + if Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0 then Grt.Errors.Error ("error during elaboration"); return; end if; @@ -175,7 +171,7 @@ package body Grt.Main is end if; -- Do the simulation. - Status := Grt.Processes.Simulation; + Status := Run_Through_Longjump (Grt.Processes.Simulation'Access); end if; if Flag_Stats then diff --git a/src/grt/grt-main.ads b/src/grt/grt-main.ads index 6dd7741..9fbf7b1 100644 --- a/src/grt/grt-main.ads +++ b/src/grt/grt-main.ads @@ -31,4 +31,11 @@ package Grt.Main is -- been assigned to generics, but before being used. procedure Ghdl_Init_Top_Generics; pragma Export (C, Ghdl_Init_Top_Generics, "__ghdl_init_top_generics"); + + type Run_Handler is access function return Integer; + + -- Run HAND through a wrapper that catch some errors (in particular on + -- windows). Returns < 0 in case of error. + function Run_Through_Longjump (Hand : Run_Handler) return Integer; + pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump"); end Grt.Main; diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb index f3b9e8c..446439f 100644 --- a/src/grt/grt-options.adb +++ b/src/grt/grt-options.adb @@ -160,8 +160,6 @@ package body Grt.Options is P (" X is expressed as a time value, without spaces: 1ns, ps..."); P (" --stop-delta=X stop the simulation cycle after X delta"); P (" --expect-failure invert exit status"); - P (" --stack-size=X set the stack size of non-sensitized processes"); - P (" --stack-max-size=X set the maximum stack size"); P (" --no-run do not simulate, only elaborate"); -- P (" --threads=N use N threads for simulation"); Grt.Hooks.Call_Help_Hooks; @@ -210,39 +208,6 @@ package body Grt.Options is end loop; end Extract_Integer; - function Extract_Size (Str : String; Option_Name : String) return Natural - is - Ok : Boolean; - Val : Integer_64; - Pos : Natural; - begin - Extract_Integer (Str, Ok, Val, Pos); - if not Ok then - Val := 1; - end if; - if Pos > Str'Last then - -- No suffix. - if Val > Integer_64(Natural'Last) then - Error_C ("Size exceeds limit for option "); - Error_E (Option_Name); - else - return Natural (Val); - end if; - end if; - if Pos = Str'Last - or else (Pos + 1 = Str'Last - and then (Str (Pos + 1) = 'b' or Str (Pos + 1) = 'o')) - then - if Str (Pos) = 'k' or Str (Pos) = 'K' then - return Natural (Val) * 1024; - elsif Str (Pos) = 'm' or Str (Pos) = 'M' then - return Natural (Val) * 1024 * 1024; - end if; - end if; - Error_C ("bad memory unit for option "); - Error_E (Option_Name); - end Extract_Size; - function To_Lower (C : Character) return Character is begin if C in 'A' .. 'Z' then @@ -434,17 +399,9 @@ package body Grt.Options is elsif Option = "--expect-failure" then Expect_Failure := True; elsif Len >= 13 and then Option (1 .. 13) = "--stack-size=" then - Stack_Size := Extract_Size - (Option (14 .. Len), "--stack-size"); - if Stack_Size > Stack_Max_Size then - Stack_Max_Size := Stack_Size; - end if; + Warning ("option --stack-size is deprecated"); elsif Len >= 17 and then Option (1 .. 17) = "--stack-max-size=" then - Stack_Max_Size := Extract_Size - (Option (18 .. Len), "--stack-size"); - if Stack_Size > Stack_Max_Size then - Stack_Size := Stack_Max_Size; - end if; + Warning ("option --stack-max-size is deprecated"); elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then if Option (12 .. Len) = "none" then Flag_Activity := Activity_None; diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads index eaf3d02..34180f1 100644 --- a/src/grt/grt-options.ads +++ b/src/grt/grt-options.ads @@ -125,12 +125,6 @@ package Grt.Options is -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles. Stop_Delta : Natural := 5000; - -- The default stack size for non-sensitized processes. - Stack_Size : Natural := 8 * 1024; - - -- The maximum stack size for non-sensitized processes. - Stack_Max_Size : Natural := 128 * 1024; - -- Set by --no-run -- If set, do not simulate, only elaborate. Flag_No_Run : Boolean := False; @@ -166,7 +160,5 @@ package Grt.Options is First_Generic_Override : Generic_Override_Acc; Last_Generic_Override : Generic_Override_Acc; private - pragma Export (C, Stack_Size); - pragma Export (C, Stack_Max_Size); pragma Export (C, Nbr_Threads, "grt_nbr_threads"); end Grt.Options; diff --git a/src/grt/grt-processes.adb b/src/grt/grt-processes.adb index 01e8394..748ab6d 100644 --- a/src/grt/grt-processes.adb +++ b/src/grt/grt-processes.adb @@ -23,7 +23,6 @@ -- 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); @@ -87,9 +86,23 @@ package body Grt.Processes is Process_First_Timeout : Std_Time := Last_Time; Process_Timeout_Chain : Process_Acc := null; + Elab_Process : Process_Acc; + procedure Init is begin - null; + -- 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); end Init; function Get_Nbr_Processes return Natural is @@ -120,28 +133,19 @@ package body Grt.Processes is 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, + Stack2 => Null_Stack2_Ptr, Resumed => False, Postponed => Postponed, State => State, Timeout => Bad_Time, Timeout_Chain_Next => null, - Timeout_Chain_Prev => null, - Stack => Stack); + Timeout_Chain_Prev => null); Process_Table.Append (P); -- Used to create drivers. Set_Current_Process (P); @@ -203,12 +207,12 @@ package body Grt.Processes is 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, - Stack => Null_Stack); + This => This); Process_Table.Append (P); -- Used to create drivers. Set_Current_Process (P); @@ -268,26 +272,42 @@ package body Grt.Processes is end Resume_Process; function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) - return System.Address + return System.Address is + Proc : constant Process_Acc := Get_Current_Process; begin - return Grt.Stack2.Allocate (Get_Stack2, Size); + return Grt.Stack2.Allocate (Proc.Stack2, Size); end Ghdl_Stack2_Allocate; function Ghdl_Stack2_Mark return Mark_Id is - St2 : Stack2_Ptr := Get_Stack2; + 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 - St2 := Grt.Stack2.Create; - Set_Stack2 (St2); + 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 + procedure Ghdl_Stack2_Release (Mark : Mark_Id) + is + Proc : constant Process_Acc := Get_Current_Process; begin - Grt.Stack2.Release (Get_Stack2, Mark); + Grt.Stack2.Release (Proc.Stack2, Mark); end Ghdl_Stack2_Release; procedure Free is new Ada.Unchecked_Deallocation @@ -374,16 +394,16 @@ package body Grt.Processes is Update_Process_First_Timeout (Proc); end Ghdl_Process_Wait_Set_Timeout; - function Ghdl_Process_Wait_Has_Timeout return Boolean + 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_Has_Timeout; + end Ghdl_Process_Wait_Timed_Out; - procedure Ghdl_Process_Wait_Wait + procedure Ghdl_Process_Wait_Suspend is Proc : constant Process_Acc := Get_Current_Process; begin @@ -392,22 +412,6 @@ package body Grt.Processes is 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 Ghdl_Process_Wait_Close @@ -497,14 +501,10 @@ package body Grt.Processes is 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) @@ -519,18 +519,8 @@ package body Grt.Processes is Error ("negative timeout clause"); end if; Proc.Timeout := Current_Time + Time; - Proc.State := State_Wait; + Proc.State := State_Delayed; 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. @@ -705,8 +695,6 @@ package body Grt.Processes is Run_Resumed : constant Integer := 2; -- Simulation is finished. Run_Finished : constant Integer := 3; - -- Failure, simulation should stop. - Run_Failure : constant Integer := -1; -- Stop/finish request from user (via std.env). Run_Stop : constant Integer := -2; pragma Unreferenced (Run_Stop); @@ -741,19 +729,14 @@ package body Grt.Processes is 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; + Proc.Subprg.all (Proc.This); 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 + function Run_Processes (Postponed : Boolean) return Natural is Table : Process_Acc_Array_Acc; Last : Natural; @@ -792,14 +775,9 @@ package body Grt.Processes is 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; + Proc.Subprg.all (Proc.This); if Grt.Options.Checks then Ghdl_Signal_Internal_Checks; - Grt.Stack2.Check_Empty (Get_Stack2); end if; end; end loop; @@ -817,9 +795,10 @@ package body Grt.Processes is end if; end Run_Processes; - function Initialization_Phase return Integer + procedure Initialization_Phase is - Status : Integer; + Status : Natural; + pragma Unreferenced (Status); begin -- Allocate processes arrays. Resume_Process_Table := @@ -857,15 +836,9 @@ package body Grt.Processes is -- - 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 @@ -874,8 +847,6 @@ package body Grt.Processes is -- Clear current_delta, will be set by Simulation_Cycle. Current_Delta := 0; - - return Run_Resumed; end Initialization_Phase; -- Launch a simulation cycle. @@ -913,17 +884,20 @@ package body Grt.Processes is 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_Sensitized; + Proc.State := State_Ready; elsif Proc.Timeout > 0 and then Proc.Timeout < Tn then Tn := Proc.Timeout; end if; @@ -941,7 +915,7 @@ package body Grt.Processes is when State_Dead => null; end case; - Proc := Proc.Timeout_Chain_Next; + Proc := Next_Proc; end loop; end; Process_First_Timeout := Tn; @@ -950,9 +924,6 @@ package body Grt.Processes is -- 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 @@ -995,8 +966,6 @@ package body Grt.Processes is 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; @@ -1016,10 +985,7 @@ package body Grt.Processes is -- Grt.Disp.Disp_Signals_Type; -- end if; - Status := Run_Through_Longjump (Initialization_Phase'Access); - if Status /= Run_Resumed then - return Status; - end if; + Initialization_Phase; Nbr_Delta_Cycles := 0; Nbr_Cycles := 0; @@ -1039,7 +1005,7 @@ package body Grt.Processes is if Disp_Time then Grt.Disp.Disp_Now; end if; - Status := Run_Through_Longjump (Simulation_Cycle'Access); + Status := Simulation_Cycle; exit when Status < 0; if Trace_Signals then Grt.Disp_Signals.Disp_All_Signals; diff --git a/src/grt/grt-processes.ads b/src/grt/grt-processes.ads index 2d953ec..ecef800 100644 --- a/src/grt/grt-processes.ads +++ b/src/grt/grt-processes.ads @@ -23,10 +23,10 @@ -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. with System; +with Ada.Unchecked_Conversion; with Grt.Stack2; use Grt.Stack2; with Grt.Types; use Grt.Types; with Grt.Signals; use Grt.Signals; -with Grt.Stacks; use Grt.Stacks; with Grt.Rtis; use Grt.Rtis; with Grt.Rtis_Addr; with Grt.Stdio; @@ -51,10 +51,6 @@ package Grt.Processes is -- If true, the simulation should be stopped. Break_Simulation : Boolean; - -- If true, there is one stack for all processes. Non-sensitized - -- processes must save their state. - One_Stack : Boolean := False; - type Process_Type is private; -- type Process_Acc is access all Process_Type; @@ -74,6 +70,21 @@ package Grt.Processes is -- Disp the name of process PROC. procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc); + -- Instance is the parameter of the process procedure. + -- This is in fact a fully opaque type whose content is private to the + -- process. + type Instance is limited private; + type Instance_Acc is access all Instance; + pragma Convention (C, Instance_Acc); + + -- A process is identified by a procedure having a single private + -- parameter (its instance). + type Proc_Acc is access procedure (Self : Instance_Acc); + pragma Convention (C, Proc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Instance_Acc, System.Address); + -- Register a process during elaboration. -- This procedure is called by vhdl elaboration code. procedure Ghdl_Process_Register (Instance : Instance_Acc; @@ -131,16 +142,12 @@ package Grt.Processes is -- Add a sensitivity for a wait. procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); -- Wait until timeout or sensitivity. - -- Return TRUE in case of timeout. - function Ghdl_Process_Wait_Suspend return Boolean; + procedure Ghdl_Process_Wait_Suspend; + -- Return TRUE if woken up by a timeout. + function Ghdl_Process_Wait_Timed_Out return Boolean; -- Finish a wait statement. procedure Ghdl_Process_Wait_Close; - -- For one stack setups, wait_suspend is decomposed into the suspension - -- procedure and the function to get resume status. - procedure Ghdl_Process_Wait_Wait; - function Ghdl_Process_Wait_Has_Timeout return Boolean; - -- Verilog. procedure Ghdl_Process_Delay (Del : Ghdl_U32); @@ -156,14 +163,9 @@ package Grt.Processes is procedure Ghdl_Protected_Init (Obj : System.Address); procedure Ghdl_Protected_Fini (Obj : System.Address); - type Run_Handler is access function return Integer; - - -- Run HAND through a wrapper that catch some errors (in particular on - -- windows). Returns < 0 in case of error. - function Run_Through_Longjump (Hand : Run_Handler) return Integer; - pragma Import (Ada, Run_Through_Longjump, "__ghdl_run_through_longjump"); - private + type Instance is null record; + -- State of a process. type Process_State is ( @@ -173,10 +175,11 @@ private -- Non-sensitized process, ready to run. State_Ready, - -- Verilog process, being suspended. + -- Non-sensitized process being suspended on a timeout (without + -- sensitivity). State_Delayed, - -- Non-sensitized process being suspended. + -- Non-sensitized process being suspended, with sensitivity. State_Wait, -- Non-sensitized process being awaked by a wait timeout. This state @@ -189,35 +192,33 @@ private State_Dead); type Process_Type is record - -- Stack for the process. - -- This must be the first field of the record (and this is the only - -- part visible). - -- Must be NULL_STACK for sensitized processes. - Stack : Stacks.Stack_Type; - -- Subprogram containing process code. Subprg : Proc_Acc; -- Instance (THIS parameter) for the subprogram. This : Instance_Acc; - -- Name of the process. - Rti : Rtis_Addr.Rti_Context; - -- True if the process is resumed and will be run at next cycle. Resumed : Boolean; -- True if the process is postponed. Postponed : Boolean; + -- State of the process. State : Process_State; - -- Timeout value for wait. - Timeout : Std_Time; + -- Secondary stack for this process. + Stack2 : Stack2_Ptr; -- Sensitivity list while the (non-sensitized) process is waiting. Sensitivity : Action_List_Acc; + -- Name of the process. + Rti : Rtis_Addr.Rti_Context; + + -- Timeout value for wait. + Timeout : Std_Time; + Timeout_Chain_Next : Process_Acc; Timeout_Chain_Prev : Process_Acc; end record; @@ -249,6 +250,8 @@ private "__ghdl_process_wait_set_timeout"); pragma Export (Ada, Ghdl_Process_Wait_Suspend, "__ghdl_process_wait_suspend"); + pragma Export (Ada, Ghdl_Process_Wait_Timed_Out, + "__ghdl_process_wait_timed_out"); pragma Export (C, Ghdl_Process_Wait_Close, "__ghdl_process_wait_close"); diff --git a/src/grt/grt-stack2.adb b/src/grt/grt-stack2.adb index 82341d0..cb56225 100644 --- a/src/grt/grt-stack2.adb +++ b/src/grt/grt-stack2.adb @@ -149,16 +149,6 @@ package body Grt.Stack2 is return To_Addr (Res); end Create; - procedure Check_Empty (S : Stack2_Ptr) - is - S2 : Stack2_Acc; - begin - S2 := To_Acc (S); - if S2 /= null and then S2.Top /= S2.First_Chunk.First then - Internal_Error ("stack2.check_empty: stack is not empty"); - end if; - end Check_Empty; - -- May be used to debug. procedure Dump_Stack2 (S : Stack2_Ptr); pragma Unreferenced (Dump_Stack2); diff --git a/src/grt/grt-stack2.ads b/src/grt/grt-stack2.ads index b3de6b7..1c0c79a 100644 --- a/src/grt/grt-stack2.ads +++ b/src/grt/grt-stack2.ads @@ -26,18 +26,41 @@ with System; with Grt.Types; use Grt.Types; -- Secondary stack management. +-- The secondary stack is used by vhdl to return object from function whose +-- type is unconstrained. This is less efficient than returning the object +-- on the stack, but compatible with any ABI. +-- +-- The management is very simple: mark and release. Allocate reserved a +-- chunk of memory from the secondary stack, Release deallocate all the +-- memory allocated since the mark. + package Grt.Stack2 is - type Stack2_Ptr is new System.Address; - Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address); + -- Designate a secondary stack. + type Stack2_Ptr is private; - type Mark_Id is new Integer_Address; + -- Indicator for a non-existing secondary stack. Create never return that + -- value. + Null_Stack2_Ptr : constant Stack2_Ptr; + + -- Type of a mark. + type Mark_Id is private; + -- Get the current mark, which indicate a current amount of allocated + -- memory. function Mark (S : Stack2_Ptr) return Mark_Id; + + -- Deallocate (free) all the memory allocated since MARK. procedure Release (S : Stack2_Ptr; Mark : Mark_Id); + + -- Allocate SIZE bytes (aligned on the maximum alignment) on stack S. function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) - return System.Address; + return System.Address; + + -- Create a secondary stack. function Create return Stack2_Ptr; +private + type Stack2_Ptr is new System.Address; + Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address); - -- Check S is empty. - procedure Check_Empty (S : Stack2_Ptr); + type Mark_Id is new Integer_Address; end Grt.Stack2; diff --git a/src/grt/grt-stacks.adb b/src/grt/grt-stacks.adb deleted file mode 100644 index adb008d..0000000 --- a/src/grt/grt-stacks.adb +++ /dev/null @@ -1,43 +0,0 @@ --- GHDL Run Time (GRT) - process stacks. --- 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.Errors; use Grt.Errors; - -package body Grt.Stacks is - procedure Error_Grow_Failed is - begin - Error ("cannot grow the stack"); - end Error_Grow_Failed; - - procedure Error_Memory_Access is - begin - Error - ("invalid memory access (dangling accesses or stack size too small)"); - end Error_Memory_Access; - - procedure Error_Null_Access is - begin - Error ("NULL access dereferenced"); - end Error_Null_Access; -end Grt.Stacks; diff --git a/src/grt/grt-stacks.ads b/src/grt/grt-stacks.ads deleted file mode 100644 index dd94340..0000000 --- a/src/grt/grt-stacks.ads +++ /dev/null @@ -1,87 +0,0 @@ --- GHDL Run Time (GRT) - process stacks. --- 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 System; use System; -with Ada.Unchecked_Conversion; - -package Grt.Stacks is - -- Instance is the parameter of the process procedure. - -- This is in fact a fully opaque type whose content is private to the - -- process. - type Instance is limited private; - type Instance_Acc is access all Instance; - pragma Convention (C, Instance_Acc); - - -- A process is identified by a procedure having a single private - -- parameter (its instance). - type Proc_Acc is access procedure (Self : Instance_Acc); - pragma Convention (C, Proc_Acc); - - function To_Address is new Ada.Unchecked_Conversion - (Instance_Acc, System.Address); - - type Stack_Type is new Address; - Null_Stack : constant Stack_Type := Stack_Type (Null_Address); - - -- Initialize the stacks package. - -- This may adjust stack sizes. - -- Must be called after grt.options.decode. - procedure Stack_Init; - - -- Create a new stack, which on first execution will call FUNC with - -- an argument ARG. - function Stack_Create (Func : Proc_Acc; Arg : Instance_Acc) - return Stack_Type; - - -- Resume stack TO and save the current context to the stack pointed by - -- CUR. - procedure Stack_Switch (To : Stack_Type; From : Stack_Type); - - -- Delete stack STACK, which must not be currently executed. - procedure Stack_Delete (Stack : Stack_Type); - - -- Error during stack handling: - -- Cannot grow the stack. - procedure Error_Grow_Failed; - pragma No_Return (Error_Grow_Failed); - - -- Invalid memory access detected (other than dereferencing a NULL access). - procedure Error_Memory_Access; - pragma No_Return (Error_Memory_Access); - - -- A NULL access is dereferenced. - procedure Error_Null_Access; - pragma No_Return (Error_Null_Access); -private - type Instance is null record; - - pragma Import (C, Stack_Init, "grt_stack_init"); - pragma Import (C, Stack_Create, "grt_stack_create"); - pragma Import (C, Stack_Switch, "grt_stack_switch"); - pragma Import (C, Stack_Delete, "grt_stack_delete"); - - pragma Export (C, Error_Grow_Failed, "grt_stack_error_grow_failed"); - pragma Export (C, Error_Memory_Access, "grt_stack_error_memory_access"); - pragma Export (C, Error_Null_Access, "grt_stack_error_null_access"); -end Grt.Stacks; diff --git a/src/grt/grt-unithread.adb b/src/grt/grt-unithread.adb index 6acb521..7e13533 100644 --- a/src/grt/grt-unithread.adb +++ b/src/grt/grt-unithread.adb @@ -80,27 +80,10 @@ package body Grt.Unithread is return Current_Process; end Get_Current_Process; - Stack2 : Stack2_Ptr; + Common_Stack2 : constant Stack2_Ptr := Create; - function Get_Stack2 return Stack2_Ptr is + function Get_Common_Stack2 return Stack2_Ptr is begin - return Stack2; - end Get_Stack2; - - procedure Set_Stack2 (St : Stack2_Ptr) is - begin - Stack2 := St; - end Set_Stack2; - - Main_Stack : Stack_Type; - - function Get_Main_Stack return Stack_Type is - begin - return Main_Stack; - end Get_Main_Stack; - - procedure Set_Main_Stack (St : Stack_Type) is - begin - Main_Stack := St; - end Set_Main_Stack; + return Common_Stack2; + end Get_Common_Stack2; end Grt.Unithread; diff --git a/src/grt/grt-unithread.ads b/src/grt/grt-unithread.ads index b35b7be..6bfacab 100644 --- a/src/grt/grt-unithread.ads +++ b/src/grt/grt-unithread.ads @@ -26,7 +26,6 @@ with System.Storage_Elements; -- Work around GNAT bug. pragma Unreferenced (System.Storage_Elements); with Grt.Signals; use Grt.Signals; with Grt.Stack2; use Grt.Stack2; -with Grt.Stacks; use Grt.Stacks; package Grt.Unithread is procedure Init; @@ -46,28 +45,17 @@ package Grt.Unithread is procedure Set_Current_Process (Proc : Process_Acc); function Get_Current_Process return Process_Acc; - -- The secondary stack for the thread. In this implementation, there is - -- only one secondary stack, shared by all processes. This is allowed, - -- because a wait statement cannot appear within a function. So at a wait - -- statement, the secondary stack must be empty. - function Get_Stack2 return Stack2_Ptr; - procedure Set_Stack2 (St : Stack2_Ptr); - - -- The main stack. This is initialized by STACK_INIT. - -- The return point. - function Get_Main_Stack return Stack_Type; - procedure Set_Main_Stack (St : Stack_Type); + -- The stack2 for all sensitized process. Since they cannot have + -- wait statements, the stack2 is always empty when the process is + -- suspended. + function Get_Common_Stack2 return Stack2_Ptr; private pragma Inline (Run_Parallel); pragma Inline (Atomic_Insert); pragma Inline (Atomic_Inc); - pragma Inline (Get_Stack2); - pragma Inline (Set_Stack2); - - pragma Inline (Get_Main_Stack); - pragma Export (C, Set_Main_Stack, "grt_set_main_stack"); pragma Inline (Set_Current_Process); pragma Inline (Get_Current_Process); + pragma Inline (Get_Common_Stack2); end Grt.Unithread; |