diff options
Diffstat (limited to 'src/translate/grt')
112 files changed, 30704 insertions, 0 deletions
diff --git a/src/translate/grt/Makefile b/src/translate/grt/Makefile new file mode 100644 index 0000000..107aef7 --- /dev/null +++ b/src/translate/grt/Makefile @@ -0,0 +1,56 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 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. +GRT_FLAGS=-g -O +GRT_ADAFLAGS=-gnatn + +ADAC=gcc +CC=gcc +GNATFLAGS=$(CFLAGS) -gnatf -gnaty3befhkmr -gnatwlu +GHDL1=../ghdl1-gcc +GRTSRCDIR=. +GRT_RANLIB=ranlib + +INSTALL=install +INSTALL_DATA=$(INSTALL) -m 644 + +prefix=/usr/local +exec_prefix=$(prefix) +libdir=$(exec_prefix)/lib +grt_libdir=$(libdir) + +target:=$(shell $(CC) -dumpmachine) + +all: grt-all +install: grt-install +clean: grt-clean + $(RM) *~ + +show_target: + echo "Target is $(target)" + +include Makefile.inc + + +GRT_CFLAGS=$(GRT_FLAGS) -Wall +ghwdump: ghwdump.o ghwlib.o + $(CC) $(GRT_CFLAGS) -o $@ ghwdump.o ghwlib.o + +ghwlib.o: ghwlib.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< +ghwdump.o: ghwdump.c ghwlib.h + $(CC) -c $(GRT_CFLAGS) -o $@ $< diff --git a/src/translate/grt/Makefile.inc b/src/translate/grt/Makefile.inc new file mode 100644 index 0000000..ec1b0df --- /dev/null +++ b/src/translate/grt/Makefile.inc @@ -0,0 +1,226 @@ +# -*- Makefile -*- for the GHDL Run Time library. +# Copyright (C) 2002, 2003, 2004, 2005 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. + +# Variables used: +# AR: ar command +# RM +# CC +# ADAC: the GNAT compiler +# GHDL1: the ghdl compiler +# GRT_RANLIB: the ranlib tool for the grt library. +# grt_libdir: the place to put grt. +# GRTSRCDIR: the source directory of grt. +# target: GCC target +# GRT_FLAGS: common (Ada + C + asm) compilation flags. +# GRT_ADAFLAGS: compilation flags for Ada + +# Convert the target variable into a space separated list of architecture, +# manufacturer, and operating system and assign each of those to its own +# variable. + +target1:=$(subst -gnu,,$(target)) +targ:=$(subst -, ,$(target1)) +arch:=$(word 1,$(targ)) +ifeq ($(words $(targ)),2) + osys:=$(word 2,$(targ)) +else + osys:=$(word 3,$(targ)) +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 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%,$(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 +endif + +# Additionnal object files (C or asm files). +GRT_ADD_OBJS:=$(GRT_TARGET_OBJS) grt-cbinding.o grt-cvpi.o + +#GRT_USE_PTHREADS=y +ifeq ($(GRT_USE_PTHREADS),y) + GRT_CFLAGS+=-DUSE_THREADS + GRT_ADD_OBJS+=grt-cthreads.o + GRT_EXTRA_LIB+=-lpthread +endif + +GRT_ARCH?=None + +# Configuration pragmas. +GRT_PRAGMA_FLAG=-gnatec$(GRTSRCDIR)/grt.adc -gnat05 + +# Rule to compile an Ada file. +GRT_ADACOMPILE=$(ADAC) -c $(GRT_FLAGS) $(GRT_PRAGMA_FLAG) -o $@ $< + +grt-all: libgrt.a grt.lst + +libgrt.a: $(GRT_ADD_OBJS) run-bind.o main.o grt-files # grt-arch.ads + $(RM) -f $@ + $(AR) rcv $@ `sed -e "/^-/d" < grt-files` $(GRT_ADD_OBJS) \ + run-bind.o main.o + $(GRT_RANLIB) $@ + +run-bind.adb: grt-force + gnatmake -c $(GNATFLAGS) -aI$(GRTSRCDIR) $(GRT_PRAGMA_FLAG) \ + ghdl_main $(GRT_ADAFLAGS) -cargs $(GRT_FLAGS) + gnatbind -Lgrt_ -o run-bind.adb -n ghdl_main.ali + +#system.ads: +# sed -e "/Configurable_Run_Time/s/False/True/" \ +# -e "/Suppress_Standard_Library/s/False/True/" \ +# < `$(ADAC) -print-file-name=adainclude/system.ads` > $@ + +run-bind.o: run-bind.adb + $(GRT_ADACOMPILE) + +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 + $(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 + $(CC) -c $(GRT_FLAGS) -o $@ $< + +times.o : $(GRTSRCDIR)/config/times.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +clock.o : $(GRTSRCDIR)/config/clock.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cbinding.o: $(GRTSRCDIR)/grt-cbinding.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cvpi.o: $(GRTSRCDIR)/grt-cvpi.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-cthreads.o: $(GRTSRCDIR)/grt-cthreads.c + $(CC) -c $(GRT_FLAGS) -o $@ $< + +grt-disp-config: + @echo "target: $(target)" + @echo "targ: $(targ)" + @echo "arch: $(arch)" + @echo "osys: $(osys)" + +grt-files: run-bind.adb + sed -e "1,/-- *BEGIN/d" -e "/-- *END/,\$$d" \ + -e "s/ -- //" < $< > $@ + +grt-arch.ads: + echo "With Grt.Arch_$(GRT_ARCH);" > $@ + echo "Package Grt.Arch renames Grt.Arch_$(GRT_ARCH);" >> $@ + +# Remove local files (they are now in the libgrt library). +# Also, remove the -shared option, in order not to build a shared library +# instead of an executable. +# Also remove -lgnat and its associated -L flags. This appears to be required +# with GNAT GPL 2005. +grt-files.in: grt-files + sed -e "\!^./!d" -e "/-shared/d" -e "/-static/d" -e "/-lgnat/d" \ + -e "\X-L/Xd" < $< > $@ + +grt.lst: grt-files.in + echo "@/libgrt.a" > $@ +ifdef GRT_EXTRA_LIB + for i in $(GRT_EXTRA_LIB); do echo $$i >> $@; done +endif + cat $< >> $@ + +grt-install: libgrt.a grt.lst + $(INSTALL_DATA) libgrt.a $(DESTDIR)$(grt_libdir)/libgrt.a + $(INSTALL_DATA) grt.lst $(DESTDIR)$(grt_libdir)/grt.lst + +grt-force: + +grt-clean: grt-force + $(RM) *.o *.ali run-bind.adb run-bind.ads *.a std_standard.s + $(RM) grt-files grt-files.in grt.lst + +.PHONY: grt-all grt-force grt-clean grt-install diff --git a/src/translate/grt/config/Makefile b/src/translate/grt/config/Makefile new file mode 100644 index 0000000..7d5f57d --- /dev/null +++ b/src/translate/grt/config/Makefile @@ -0,0 +1,14 @@ +CFLAGS=-Wall -g + +#ARCH_OBJS=i386.o linux.o +ARCH_OBJS=ppc.o linux.o + +teststack: teststack.o $(ARCH_OBJS) + $(CC) -o $@ $< $(ARCH_OBJS) + +ppc.o: ppc.S + $(CC) -c -o $@ -g $< + +clean: + $(RM) -f *.o *~ teststack + diff --git a/src/translate/grt/config/amd64.S b/src/translate/grt/config/amd64.S new file mode 100644 index 0000000..0a7f004 --- /dev/null +++ b/src/translate/grt/config/amd64.S @@ -0,0 +1,131 @@ +/* GRT stack implementation for amd64 (x86_64) + Copyright (C) 2005 - 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. +*/ + .file "amd64.S" + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + .text + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + mov 0(%rsp),%rdi + call *8(%rsp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + Args: FUNC (RDI), ARG (RSI) + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushq %rbp + movq %rsp,%rbp + /* Save args. */ + sub $0x10,%rsp + mov %rdi,-8(%rbp) + mov %rsi,-16(%rbp) + + /* Allocate the stack, and exit in case of failure */ + callq NAME(grt_stack_allocate) + test %rax,%rax + je .Ldone + + /* Note: %RAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + mov -8(%rbp), %rdi + mov %rdi, -8(%rax) + /* The argument. */ + mov -16(%rbp), %rsi + mov %rsi, -16(%rax) + /* The return function. Must be 8 mod 16. */ +#if __APPLE__ + movq _grt_stack_loop@GOTPCREL(%rip), %rsi + movq %rsi, -24(%rax) +#else + movq $grt_stack_loop, -24(%rax) +#endif + /* The context. */ + mov %rbp, -32(%rax) + mov %rbx, -40(%rax) + mov %r12, -48(%rax) + mov %r13, -56(%rax) + mov %r14, -64(%rax) + mov %r15, -72(%rax) + + /* Save the new stack pointer to the stack context. */ + lea -72(%rax), %rsi + mov %rsi, (%rax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + + /* Arguments: TO (RDI), FROM (RSI) [VAL (RDX)] + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* Save call-used registers. */ + pushq %rbp + pushq %rbx + pushq %r12 + pushq %r13 + pushq %r14 + pushq %r15 + /* Save the current stack. */ + movq %rsp, (%rsi) + /* Stack switch. */ + movq (%rdi), %rsp + /* Restore call-used registers. */ + popq %r15 + popq %r14 + popq %r13 + popq %r12 + popq %rbx + popq %rbp + /* Return val. */ + movq %rdx, %rax + /* Run. */ + ret +END(grt_stack_switch) + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/chkstk.S b/src/translate/grt/config/chkstk.S new file mode 100644 index 0000000..ab244d0 --- /dev/null +++ b/src/translate/grt/config/chkstk.S @@ -0,0 +1,53 @@ +/* GRT stack implementation for x86. + 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. +*/ + .file "chkstk.S" + .version "01.01" + + .text + +#ifdef __APPLE__ +#define __chkstk ___chkstk +#endif + + /* Function called to loop on the process. */ + .align 4 +#ifdef __ELF__ + .type __chkstk,@function +#endif + .globl __chkstk +__chkstk: + testl %eax,%eax + je 0f + subl $4,%eax /* 4 bytes already used by call. */ + subl %eax,%esp + jmp *(%esp,%eax) +0: + ret +#ifdef __ELF__ + .size __chkstk, . - __chkstk +#endif + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/clock.c b/src/translate/grt/config/clock.c new file mode 100644 index 0000000..242af60 --- /dev/null +++ b/src/translate/grt/config/clock.c @@ -0,0 +1,43 @@ +/* GRT C bindings for time. + 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. +*/ +#include <time.h> + +int +grt_get_clk_tck (void) +{ + return CLOCKS_PER_SEC; +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + + *wall = clock (); + *user = 0; + *sys = 0; +} + diff --git a/src/translate/grt/config/i386.S b/src/translate/grt/config/i386.S new file mode 100644 index 0000000..00d4719 --- /dev/null +++ b/src/translate/grt/config/i386.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + 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. +*/ + .file "i386.S" + .version "01.01" + + .text + +#ifdef __ELF__ +#define ENTRY(func) .align 4; .globl func; .type func,@function; func: +#define END(func) .size func, . - func +#define NAME(name) name +#elif __APPLE__ +#define ENTRY(func) .align 4; .globl _##func; _##func: +#define END(func) +#define NAME(name) _##name +#else +#define ENTRY(func) .align 4; func: +#define END(func) +#define NAME(name) name +#endif + + /* Function called to loop on the process. */ +ENTRY(grt_stack_loop) + call *4(%esp) + jmp NAME(grt_stack_loop) +END(grt_stack_loop) + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; + */ +ENTRY(grt_stack_create) + /* Standard prologue. */ + pushl %ebp + movl %esp,%ebp + /* Keep aligned (call + pushl + 8 = 16 bytes). */ + subl $8,%esp + + /* Allocate the stack, and exit in case of failure */ + call NAME(grt_stack_allocate) + testl %eax,%eax + je .Ldone + + /* Note: %EAX contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* The function to be executed. */ + movl 8(%ebp), %ecx + movl %ecx, -4(%eax) + /* The argument. */ + movl 12(%ebp), %ecx + movl %ecx, -8(%eax) + /* The return function. */ +#if __APPLE__ + call ___x86.get_pc_thunk.cx +L1$pb: + movl L_grt_stack_loop$non_lazy_ptr-L1$pb(%ecx), %ecx + movl %ecx,-12(%eax) +#else + movl $NAME(grt_stack_loop), -12(%eax) +#endif + /* The context. */ + movl %ebx, -16(%eax) + movl %esi, -20(%eax) + movl %edi, -24(%eax) + movl %ebp, -28(%eax) + + /* Save the new stack pointer to the stack context. */ + leal -28(%eax), %ecx + movl %ecx, (%eax) + +.Ldone: + leave + ret +END(grt_stack_create) + + + /* Arguments: TO, FROM + Both are pointers to a stack_context. */ +ENTRY(grt_stack_switch) + /* TO -> ECX. */ + movl 4(%esp), %ecx + /* FROM -> EDX. */ + movl 8(%esp), %edx + /* Save call-used registers. */ + pushl %ebx + pushl %esi + pushl %edi + pushl %ebp + /* Save the current stack. */ + movl %esp, (%edx) + /* Stack switch. */ + movl (%ecx), %esp + /* Restore call-used registers. */ + popl %ebp + popl %edi + popl %esi + popl %ebx + /* Run. */ + ret +END(grt_stack_switch) + + +#if __APPLE__ + .section __TEXT,__textcoal_nt,coalesced,pure_instructions + .weak_definition ___x86.get_pc_thunk.cx + .private_extern ___x86.get_pc_thunk.cx +___x86.get_pc_thunk.cx: + movl (%esp), %ecx + ret + + .section __IMPORT,__pointers,non_lazy_symbol_pointers +L_grt_stack_loop$non_lazy_ptr: + .indirect_symbol _grt_stack_loop + .long 0 +#endif + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/ia64.S b/src/translate/grt/config/ia64.S new file mode 100644 index 0000000..9ce3800 --- /dev/null +++ b/src/translate/grt/config/ia64.S @@ -0,0 +1,331 @@ +/* GRT stack implementation for ia64. + 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. +*/ + .file "ia64.S" + .pred.safe_across_calls p1-p5,p16-p63 + + .text + .align 16 + .proc grt_stack_loop +grt_stack_loop: + alloc r32 = ar.pfs, 0, 1, 1, 0 + .body + ;; +1: mov r33 = r4 + br.call.sptk.many b0 = b1 + ;; + br 1b + .endp + + frame_size = 480 + + .global grt_stack_switch# + .proc grt_stack_switch# + /* r32: struct stack_context *TO, r33: struct stack_context *FROM. */ + // Registers to be saved: + // ar.rsc, ar.bsp, ar.pfs, ar.lc, ar.rnat [5] + // gp, r4-r7 (+ Nat) [6] + // f2-f5, f16-f31 [20] + // p1-p5, p16-p63 [1] ??? + // b1-b5 [5] + // f2-f5, f16-f31 [20*16] +grt_stack_switch: + .prologue 2, 2 + .vframe r2 + { + alloc r31=ar.pfs, 2, 0, 0, 0 + mov r14 = ar.rsc + adds r12 = -frame_size, r12 + .body + ;; + } + // Save ar.rsc, ar.bsp, ar.pfs + { + st8 [r12] = r14 // sp + 0 <- ar.rsc + mov r15 = ar.bsp + adds r22 = (5*8), r12 + ;; + } + { + st8.spill [r22] = r1, 8 // sp + 40 <- r1 + ;; + st8.spill [r22] = r4, 8 // sp + 48 <- r4 + adds r20 = 8, r12 + ;; + } + st8 [r20] = r15, 8 // sp + 8 <- ar.bsp + st8.spill [r22] = r5, 8 // sp + 56 <- r5 + mov r15 = ar.lc + ;; + { + st8 [r20] = r31, 8 // sp + 16 <- ar.pfs + // Flush dirty registers to the backing store + flushrs + mov r14 = b0 + ;; + } + { + st8 [r20] = r15, 8 // sp + 24 <- ar.lc + // Set the RSE in enforced lazy mode. + mov ar.rsc = 0 + ;; + } + { + // Save sp. + st8 [r33] = r12 + mov r15 = ar.rnat + mov r16 = b1 + ;; + } + { + st8.spill [r22] = r6, 8 // sp + 64 <- r6 + st8 [r20] = r15, 64 // sp + 32 <- ar.rnat + ;; + } + { + st8.spill [r22] = r7, 16 // sp + 72 <- r7 + st8 [r20] = r14, 8 // sp + 96 <- b0 + mov r15 = b2 + ;; + } + { + mov r17 = ar.unat + ;; + st8 [r22] = r17, 24 // sp + 88 <- ar.unat + mov r14 = b3 + ;; + } + { + st8 [r20] = r16, 16 // sp + 104 <- b1 + st8 [r22] = r15, 16 // sp + 112 <- b2 + mov r17 = b4 + ;; + } + { + st8 [r20] = r14, 16 // sp + 120 <- b3 + st8 [r22] = r17, 16 // sp + 128 <- b4 + mov r15 = b5 + ;; + } + { + // Read new sp. + ld8 r21 = [r32] + ;; + st8 [r20] = r15, 24 // sp + 136 <- b5 + mov r14 = pr + ;; + } + ;; + st8 [r22] = r14, 32 // sp + 144 <- pr + stf.spill [r20] = f2, 32 // sp + 160 <- f2 + ;; + stf.spill [r22] = f3, 32 // sp + 176 <- f3 + stf.spill [r20] = f4, 32 // sp + 192 <- f4 + ;; + stf.spill [r22] = f5, 32 // sp + 208 <- f5 + stf.spill [r20] = f16, 32 // sp + 224 <- f16 + ;; + stf.spill [r22] = f17, 32 // sp + 240 <- f17 + stf.spill [r20] = f18, 32 // sp + 256 <- f18 + ;; + stf.spill [r22] = f19, 32 // sp + 272 <- f19 + stf.spill [r20] = f20, 32 // sp + 288 <- f20 + ;; + stf.spill [r22] = f21, 32 // sp + 304 <- f21 + stf.spill [r20] = f22, 32 // sp + 320 <- f22 + ;; + stf.spill [r22] = f23, 32 // sp + 336 <- f23 + stf.spill [r20] = f24, 32 // sp + 352 <- f24 + ;; + stf.spill [r22] = f25, 32 // sp + 368 <- f25 + stf.spill [r20] = f26, 32 // sp + 384 <- f26 + ;; + stf.spill [r22] = f27, 32 // sp + 400 <- f27 + stf.spill [r20] = f28, 32 // sp + 416 <- f28 + ;; + stf.spill [r22] = f29, 32 // sp + 432 <- f29 + stf.spill [r20] = f30, 32 // sp + 448 <- f30 + ;; + { + stf.spill [r22] = f31, 32 // sp + 464 <- f31 + invala + adds r20 = 8, r21 + ;; + } + ld8 r14 = [r21], 88 // sp + 0 (ar.rsc) + ld8 r16 = [r20], 8 // sp + 8 (ar.bsp) + ;; + ld8 r15 = [r21], -56 // sp + 88 (ar.unat) + ;; + ld8 r18 = [r20], 8 // sp + 16 (ar.pfs) + mov ar.unat = r15 + ld8 r17 = [r21], 8 // sp + 32 (ar.rnat) + ;; + ld8 r15 = [r20], 72 // sp + 24 (ar.lc) + ld8.fill r1 = [r21], 8 // sp + 40 (r1) + mov ar.bspstore = r16 + ;; + ld8.fill r4 = [r21], 8 // sp + 48 (r4) + mov ar.pfs = r18 + mov ar.rnat = r17 + ;; + mov ar.rsc = r14 + mov ar.lc = r15 + ld8 r17 = [r20], 8 // sp + 96 (b0) + ;; + { + ld8.fill r5 = [r21], 8 // sp + 56 (r5) + ld8 r14 = [r20], 8 // sp + 104 (b1) + mov b0 = r17 + ;; + } + { + ld8.fill r6 = [r21], 8 // sp + 64 (r6) + ld8 r15 = [r20], 8 // sp + 112 (b2) + mov b1 = r14 + ;; + } + ld8.fill r7 = [r21], 64 // sp + 72 (r7) + ld8 r14 = [r20], 8 // sp + 120 (b3) + mov b2 = r15 + ;; + ld8 r15 = [r20], 16 // sp + 128 (b4) + ld8 r16 = [r21], 40 // sp + 136 (b5) + mov b3 = r14 + ;; + { + ld8 r14 = [r20], 16 // sp + 144 (pr) + ;; + ldf.fill f2 = [r20], 32 // sp + 160 (f2) + mov b4 = r15 + ;; + } + ldf.fill f3 = [r21], 32 // sp + 176 (f3) + ldf.fill f4 = [r20], 32 // sp + 192 (f4) + mov b5 = r16 + ;; + ldf.fill f5 = [r21], 32 // sp + 208 (f5) + ldf.fill f16 = [r20], 32 // sp + 224 (f16) + mov pr = r14, -1 + ;; + ldf.fill f17 = [r21], 32 // sp + 240 (f17) + ldf.fill f18 = [r20], 32 // sp + 256 (f18) + ;; + ldf.fill f19 = [r21], 32 // sp + 272 (f19) + ldf.fill f20 = [r20], 32 // sp + 288 (f20) + ;; + ldf.fill f21 = [r21], 32 // sp + 304 (f21) + ldf.fill f22 = [r20], 32 // sp + 320 (f22) + ;; + ldf.fill f23 = [r21], 32 // sp + 336 (f23) + ldf.fill f24 = [r20], 32 // sp + 352 (f24) + ;; + ldf.fill f25 = [r21], 32 // sp + 368 (f25) + ldf.fill f26 = [r20], 32 // sp + 384 (f26) + ;; + ldf.fill f27 = [r21], 32 // sp + 400 (f27) + ldf.fill f28 = [r20], 32 // sp + 416 (f28) + ;; + ldf.fill f29 = [r21], 32 // sp + 432 (f29) + ldf.fill f30 = [r20], 32 // sp + 448 (f30) + ;; + ldf.fill f31 = [r21], 32 // sp + 464 (f31) + mov r12 = r20 + br.ret.sptk.many b0 + ;; + .endp grt_stack_switch# + + .align 16 + // r32: func, r33: arg + .global grt_stack_create# + .proc grt_stack_create# +grt_stack_create: + .prologue 14, 34 + .save ar.pfs, r35 + alloc r35 = ar.pfs, 2, 3, 0, 0 + .save rp, r34 + // Compute backing store. + movl r14 = stack_max_size + ;; + .body + { + ld4 r36 = [r14] // r14: bsp + mov r34 = b0 + br.call.sptk.many b0 = grt_stack_allocate# + ;; + } + { + ld8 r22 = [r32], 8 // read ip (-> b1) + ;; + ld8 r23 = [r32] // read r1 from func + adds r21 = -(frame_size + 16) + 32, r8 + ;; + } + { + st8 [r21] = r0, -32 // sp + 32 (ar.rnat = 0) + ;; + st8 [r8] = r21 // Save cur_sp + mov r18 = 0x0f // ar.rsc: LE, PL=3, Eager + ;; + } + { + st8 [r21] = r18, 40 // sp + 0 (ar.rsc) + ;; + st8 [r21] = r23, 64 // sp + 40 (r1 = func.r1) + mov b0 = r34 + ;; + } + { + st8 [r21] = r22, -96 // sp + 104 (b1 = func.ip) + movl r15 = grt_stack_loop + ;; + } + sub r14 = r8, r36 // Backing store base + ;; + adds r14 = 16, r14 // Add sizeof (stack_context) + adds r20 = 40, r21 + ;; + { + st8 [r21] = r14, 88 // sp + 8 (ar.bsp) + ;; + st8 [r21] = r15, -80 // sp + 96 (b0 = grt_stack_loop) + mov r16 = (0 << 7) | 1 // CFM: sol=0, sof=1 + ;; + } + { + st8 [r21] = r16, 8 // sp + 16 (ar.pfs) + ;; + st8 [r21] = r0, 24 // sp + 24 (ar.lc) + mov ar.pfs = r35 + ;; + } + { + st8 [r20] = r0, 8 // sp + 32 (ar.rnat) + st8 [r21] = r33 // sp + 48 (r4 = arg) + br.ret.sptk.many b0 + ;; + } + .endp grt_stack_create# + .ident "GCC: (GNU) 4.0.2" diff --git a/src/translate/grt/config/linux.c b/src/translate/grt/config/linux.c new file mode 100644 index 0000000..74dce09 --- /dev/null +++ b/src/translate/grt/config/linux.c @@ -0,0 +1,361 @@ +/* GRT stacks implementation for linux and other *nix. + 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. +*/ +#define _GNU_SOURCE +#include <unistd.h> +#include <sys/mman.h> +#include <signal.h> +#include <fcntl.h> +#include <sys/ucontext.h> +#include <stdlib.h> +//#include <stdint.h> + +#ifdef __APPLE__ +#define MAP_ANONYMOUS MAP_ANON +#endif + +/* On x86, the stack growns downward. */ +#define STACK_GROWNS_DOWNWARD 1 + +#ifdef __linux__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGSEGV +#endif +#ifdef __FreeBSD__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGSEGV +#endif +#ifdef __APPLE__ +/* If set, SIGSEGV is caught in order to automatically grow the stacks. */ +#define EXTEND_STACK 1 +#define STACK_SIGNAL SIGBUS +#endif + +/* Defined in Grt.Options. */ +extern unsigned int stack_size; +extern unsigned int stack_max_size; + +/* Size of a memory page. */ +static size_t page_size; + +extern void grt_stack_error_grow_failed (void); +extern void grt_stack_error_null_access (void); +extern void grt_stack_error_memory_access (void); +extern void grt_overflow_error (void); + +/* Definitions: + The base of the stack is the address before the first available byte on the + stack. If the stack grows downward, the base is equal to the high bound. +*/ + +/* Per stack context. + This context is allocated at the top (or bottom if the stack grows + upward) of the stack. + Therefore, the base of the stack can be easily deduced from the context. */ +struct stack_context +{ + /* The current stack pointer. */ + void *cur_sp; + /* The current stack length. */ + size_t cur_length; +}; + +/* If MAP_ANONYMOUS is not defined, use /dev/zero. */ +#ifndef MAP_ANONYMOUS +#define USE_DEV_ZERO +static int dev_zero_fd; +#define MAP_ANONYMOUS 0 +#define MMAP_FILEDES dev_zero_fd +#else +#define MMAP_FILEDES -1 +#endif + +#if EXTEND_STACK +/* This is the current process being run. */ +extern struct stack_context *grt_get_current_process (void); + +/* Stack used for signals. + The stack must be different from the running stack, because we want to be + able to extend the running stack. When the stack need to be extended, the + current stack pointer does not point to a valid address. Therefore, the + stack cannot be used or else a second SIGSEGV is generated while the + arguments are pushed. */ +static unsigned long sig_stack[SIGSTKSZ / sizeof (long)]; + +/* Signal stack descriptor. */ +static stack_t sig_stk; + +static struct sigaction prev_sigsegv_act; +static struct sigaction sigsegv_act; + +/* The following code assumes stack grows downward. */ +#if !STACK_GROWNS_DOWNWARD +#error "Not implemented" +#endif + +#ifdef __APPLE__ +/* 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 + +/* Handler for SIGSEGV signal, which grow the stack. */ +static void grt_sigsegv_handler (int signo, siginfo_t *info, void *ptr) +{ + static int in_handler; + void *addr; + struct stack_context *ctxt; + void *stack_high; + void *stack_low; + void *n_low; + size_t n_len; + ucontext_t *uctxt = (ucontext_t *)ptr; + + in_handler++; + +#ifdef __linux__ +#ifdef __i386__ + /* Linux generates a SIGSEGV (!) for an overflow exception. */ + if (uctxt->uc_mcontext.gregs[REG_TRAPNO] == 4) + { + grt_overflow_error (); + } +#endif +#endif + + if (info == NULL || grt_get_current_process () == NULL || in_handler > 1) + { + /* We loose. */ + sigaction (STACK_SIGNAL, &prev_sigsegv_act, NULL); + return; + } + + addr = info->si_addr; + + /* Check ADDR belong to the stack. */ + ctxt = grt_get_current_process ()->cur_sp; + stack_high = (void *)(ctxt + 1); + stack_low = stack_high - stack_max_size; + if (addr > stack_high || addr < stack_low) + { + /* Out of the stack. */ + if (addr < (void *)page_size) + grt_stack_error_null_access (); + else + grt_stack_error_memory_access (); + } + /* Compute the address of the faulting page. */ + n_low = (void *)((unsigned long)addr & ~(page_size - 1)); + + /* Should not happen. */ + if (n_low < stack_low) + abort (); + + /* Allocate one more page, if possible. */ + if (n_low != stack_low) + n_low -= page_size; + + /* Compute the new length. */ + n_len = stack_high - n_low; + + if (mmap (n_low, n_len - ctxt->cur_length, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) + != n_low) + { + /* Cannot grow the stack. */ + grt_stack_error_grow_failed (); + } + + ctxt->cur_length = n_len; + + sigaction (STACK_SIGNAL, &sigsegv_act, NULL); + + in_handler--; + + /* Hopes we can resume! */ + return; +} + +static void grt_signal_setup (void) +{ + 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 + + /* Use an alternate stack during signals. */ + sig_stk.ss_sp = sig_stack; + sig_stk.ss_size = sizeof (sig_stack); + sig_stk.ss_flags = 0; + sigaltstack (&sig_stk, NULL); + + /* We don't care about the return status. + If the handler is not installed, then some feature are lost. */ + sigaction (STACK_SIGNAL, &sigsegv_act, &prev_sigsegv_act); + +#ifdef __APPLE__ + { + 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, NULL); + } +#endif +} +#endif + +/* Context for the main stack. */ +#ifdef USE_THREADS +#define THREAD __thread +#else +#define THREAD +#endif +static THREAD struct stack_context main_stack_context; + +extern void grt_set_main_stack (struct stack_context *stack); + +void +grt_stack_new_thread (void) +{ + main_stack_context.cur_sp = NULL; + main_stack_context.cur_length = 0; + grt_set_main_stack (&main_stack_context); +} + +void +grt_stack_init (void) +{ + size_t pg_round; + + page_size = getpagesize (); + pg_round = page_size - 1; + + /* Align size. */ + stack_size = (stack_size + pg_round) & ~pg_round; + stack_max_size = (stack_max_size + pg_round) & ~pg_round; + + /* Set mimum values. */ + if (stack_size < 2 * page_size) + stack_size = 2 * page_size; + if (stack_max_size < (stack_size + 2 * page_size)) + stack_max_size = stack_size + 2 * page_size; + + /* Initialize the main stack context. */ + main_stack_context.cur_sp = NULL; + main_stack_context.cur_length = 0; + grt_set_main_stack (&main_stack_context); + +#ifdef USE_DEV_ZERO + dev_zero_fd = open ("/dev/zero", O_RDWR); + if (dev_zero_fd < 0) + abort (); +#endif + +#if EXTEND_STACK + grt_signal_setup (); +#endif +} + +/* Allocate a stack. + Called by i386.S */ +struct stack_context * +grt_stack_allocate (void) +{ + struct stack_context *res; + void *r; + void *base; + + /* Allocate the stack, but without any rights. This is a guard. */ + base = (void *)mmap (NULL, stack_max_size, PROT_NONE, + MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0); + + if (base == (void *)-1) + return NULL; + + /* Set rights on the allocated stack. */ +#if STACK_GROWNS_DOWNWARD + r = base + stack_max_size - stack_size; +#else + r = base; +#endif + if (mmap (r, stack_size, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) + != r) + return NULL; + +#if STACK_GROWNS_DOWNWARD + res = (struct stack_context *) + (base + stack_max_size - sizeof (struct stack_context)); +#else + res = (struct stack_context *)(base + sizeof (struct stack_context)); +#endif + +#ifdef __ia64__ + /* Also allocate BSP. */ + if (mmap (base, page_size, PROT_READ | PROT_WRITE, + MAP_FIXED | MAP_PRIVATE | MAP_ANONYMOUS, MMAP_FILEDES, 0) != base) + return NULL; +#endif + + res->cur_sp = (void *)res; + res->cur_length = stack_size; + return res; +} + +#include <setjmp.h> +static int run_env_en; +static jmp_buf run_env; + +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; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + diff --git a/src/translate/grt/config/ppc.S b/src/translate/grt/config/ppc.S new file mode 100644 index 0000000..bedd48a --- /dev/null +++ b/src/translate/grt/config/ppc.S @@ -0,0 +1,334 @@ +/* GRT stack implementation for ppc. + Copyright (C) 2005 - 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. +*/ + .file "ppc.S" + + .section ".text" + +#define OFF 240 + +#define GREG(x) x +#define FREG(x) x + +#define r0 GREG(0) +#define r1 GREG(1) +#define r2 GREG(2) +#define r3 GREG(3) +#define r4 GREG(4) +#define r5 GREG(5) +#define r6 GREG(6) +#define r7 GREG(7) +#define r8 GREG(8) +#define r9 GREG(9) +#define r10 GREG(10) +#define r11 GREG(11) +#define r12 GREG(12) +#define r13 GREG(13) +#define r14 GREG(14) +#define r15 GREG(15) +#define r16 GREG(16) +#define r17 GREG(17) +#define r18 GREG(18) +#define r19 GREG(19) +#define r20 GREG(20) +#define r21 GREG(21) +#define r22 GREG(22) +#define r23 GREG(23) +#define r24 GREG(24) +#define r25 GREG(25) +#define r26 GREG(26) +#define r27 GREG(27) +#define r28 GREG(28) +#define r29 GREG(29) +#define r30 GREG(30) +#define r31 GREG(31) + +#define f0 FREG(0) +#define f1 FREG(1) +#define f2 FREG(2) +#define f3 FREG(3) +#define f4 FREG(4) +#define f5 FREG(5) +#define f6 FREG(6) +#define f7 FREG(7) +#define f8 FREG(8) +#define f9 FREG(9) +#define f10 FREG(10) +#define f11 FREG(11) +#define f12 FREG(12) +#define f13 FREG(13) +#define f14 FREG(14) +#define f15 FREG(15) +#define f16 FREG(16) +#define f17 FREG(17) +#define f18 FREG(18) +#define f19 FREG(19) +#define f20 FREG(20) +#define f21 FREG(21) +#define f22 FREG(22) +#define f23 FREG(23) +#define f24 FREG(24) +#define f25 FREG(25) +#define f26 FREG(26) +#define f27 FREG(27) +#define f28 FREG(28) +#define f29 FREG(29) +#define f30 FREG(30) +#define f31 FREG(31) + + /* Stack structure is: + +4 : cur_length \ Stack + +0 : cur_sp / Context + -4 : arg + -8 : func + + -12: pad + -16: pad + -20: LR save word + -24: Back chain + + -28: fp/gp saved registers. + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,@function +grt_stack_loop: + /* Get function. */ + lwz r0,16(r1) + /* Get argument. */ + lwz r3,20(r1) + mtlr r0 + blrl + b grt_stack_loop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,@function +grt_stack_create: + /* Standard prologue. */ + stwu r1,-32(r1) + mflr r0 + stw r0,36(r1) + + /* Save arguments. */ + stw r3,24(r1) + stw r4,28(r1) + + /* Allocate the stack, and exit in case of failure */ + bl grt_stack_allocate + cmpwi 0,r3,0 + beq- .Ldone + + /* Note: r3 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + /* Align the stack. */ + addi r5,r3,-24 + + /* Save the parameters. */ + lwz r6,24(r1) + stw r6,16(r5) + lwz r7,28(r1) + stw r7,20(r5) + + /* The return function. */ + lis r4,grt_stack_loop@ha + la r4,grt_stack_loop@l(r4) + stw r4,4(r5) + /* Back-Chain. */ + addi r4,r1,32 + stw r4,0(r5) + + /* Save register. + They should be considered as garbage. */ + addi r4,r5,-OFF + + stfd f31,(OFF - 8)(r4) + stfd f30,(OFF - 16)(r4) + stfd f29,(OFF - 24)(r4) + stfd f28,(OFF - 32)(r4) + stfd f27,(OFF - 40)(r4) + stfd f26,(OFF - 48)(r4) + stfd f25,(OFF - 56)(r4) + stfd f24,(OFF - 64)(r4) + stfd f23,(OFF - 72)(r4) + stfd f22,(OFF - 80)(r4) + stfd f21,(OFF - 88)(r4) + stfd f20,(OFF - 96)(r4) + stfd f19,(OFF - 104)(r4) + stfd f18,(OFF - 112)(r4) + stfd f17,(OFF - 120)(r4) + stfd f16,(OFF - 128)(r4) + stfd f15,(OFF - 136)(r4) + stfd f14,(OFF - 144)(r4) + stw r31,(OFF - 148)(r4) + stw r30,(OFF - 152)(r4) + stw r29,(OFF - 156)(r4) + stw r28,(OFF - 160)(r4) + stw r27,(OFF - 164)(r4) + stw r26,(OFF - 168)(r4) + stw r25,(OFF - 172)(r4) + stw r24,(OFF - 176)(r4) + stw r23,(OFF - 180)(r4) + stw r22,(OFF - 184)(r4) + stw r21,(OFF - 188)(r4) + stw r20,(OFF - 192)(r4) + stw r19,(OFF - 196)(r4) + stw r18,(OFF - 200)(r4) + stw r17,(OFF - 204)(r4) + stw r16,(OFF - 208)(r4) + stw r15,(OFF - 212)(r4) + stw r14,(OFF - 216)(r4) + mfcr r0 + stw r0, (OFF - 220)(r4) + + /* Save stack pointer. */ + stw r4, 0(r3) + +.Ldone: + lwz r0,36(r1) + mtlr r0 + addi r1,r1,32 + blr + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,@function +grt_stack_switch: + /* Standard prologue, save return address. */ + stwu r1,(-OFF)(r1) + mflr r0 + stw r0,(OFF + 4)(r1) + + /* Save r14-r31, f14-f31, CR + This is 18 words + 18 double words, ie 216 bytes. */ + /* Maybe use the savefpr function ? */ + stfd f31,(OFF - 8)(r1) + stfd f30,(OFF - 16)(r1) + stfd f29,(OFF - 24)(r1) + stfd f28,(OFF - 32)(r1) + stfd f27,(OFF - 40)(r1) + stfd f26,(OFF - 48)(r1) + stfd f25,(OFF - 56)(r1) + stfd f24,(OFF - 64)(r1) + stfd f23,(OFF - 72)(r1) + stfd f22,(OFF - 80)(r1) + stfd f21,(OFF - 88)(r1) + stfd f20,(OFF - 96)(r1) + stfd f19,(OFF - 104)(r1) + stfd f18,(OFF - 112)(r1) + stfd f17,(OFF - 120)(r1) + stfd f16,(OFF - 128)(r1) + stfd f15,(OFF - 136)(r1) + stfd f14,(OFF - 144)(r1) + stw r31,(OFF - 148)(r1) + stw r30,(OFF - 152)(r1) + stw r29,(OFF - 156)(r1) + stw r28,(OFF - 160)(r1) + stw r27,(OFF - 164)(r1) + stw r26,(OFF - 168)(r1) + stw r25,(OFF - 172)(r1) + stw r24,(OFF - 176)(r1) + stw r23,(OFF - 180)(r1) + stw r22,(OFF - 184)(r1) + stw r21,(OFF - 188)(r1) + stw r20,(OFF - 192)(r1) + stw r19,(OFF - 196)(r1) + stw r18,(OFF - 200)(r1) + stw r17,(OFF - 204)(r1) + stw r16,(OFF - 208)(r1) + stw r15,(OFF - 212)(r1) + stw r14,(OFF - 216)(r1) + mfcr r0 + stw r0, (OFF - 220)(r1) + + /* Save stack pointer. */ + stw r1, 0(r4) + + /* Load stack pointer. */ + lwz r1, 0(r3) + + + lfd f31,(OFF - 8)(r1) + lfd f30,(OFF - 16)(r1) + lfd f29,(OFF - 24)(r1) + lfd f28,(OFF - 32)(r1) + lfd f27,(OFF - 40)(r1) + lfd f26,(OFF - 48)(r1) + lfd f25,(OFF - 56)(r1) + lfd f24,(OFF - 64)(r1) + lfd f23,(OFF - 72)(r1) + lfd f22,(OFF - 80)(r1) + lfd f21,(OFF - 88)(r1) + lfd f20,(OFF - 96)(r1) + lfd f19,(OFF - 104)(r1) + lfd f18,(OFF - 112)(r1) + lfd f17,(OFF - 120)(r1) + lfd f16,(OFF - 128)(r1) + lfd f15,(OFF - 136)(r1) + lfd f14,(OFF - 144)(r1) + lwz r31,(OFF - 148)(r1) + lwz r30,(OFF - 152)(r1) + lwz r29,(OFF - 156)(r1) + lwz r28,(OFF - 160)(r1) + lwz r27,(OFF - 164)(r1) + lwz r26,(OFF - 168)(r1) + lwz r25,(OFF - 172)(r1) + lwz r24,(OFF - 176)(r1) + lwz r23,(OFF - 180)(r1) + lwz r22,(OFF - 184)(r1) + lwz r21,(OFF - 188)(r1) + lwz r20,(OFF - 192)(r1) + lwz r19,(OFF - 196)(r1) + lwz r18,(OFF - 200)(r1) + lwz r17,(OFF - 204)(r1) + lwz r16,(OFF - 208)(r1) + lwz r15,(OFF - 212)(r1) + lwz r14,(OFF - 216)(r1) + lwz r0, (OFF - 220)(r1) + mtcr r0 + + lwz r0,(OFF + 4)(r1) + mtlr r0 + addi r1,r1,OFF + blr + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/pthread.c b/src/translate/grt/config/pthread.c new file mode 100644 index 0000000..189ae90 --- /dev/null +++ b/src/translate/grt/config/pthread.c @@ -0,0 +1,239 @@ +/* GRT stack implementation based on pthreads. + Copyright (C) 2003 - 2014 Felix Bertram & 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. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: pthread port of stacks package, for use with MacOSX +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2003may22, FB, created. +//----------------------------------------------------------------------------- + +#include <pthread.h> +#include <stdlib.h> +#include <stdio.h> +#include <setjmp.h> +#include <assert.h> + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ + pthread_t thread; // stack's thread + pthread_mutex_t mutex; // mutex to suspend/resume thread +#if defined(__CYGWIN__) + pthread_mutexattr_t mxAttr; +#endif + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + +static Stack_Type_t main_stack_context; +static Stack_Type_t *current; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//---------------------------------------------------------------------------- +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ + int res; + INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&main_stack_context.mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&main_stack_context.mxAttr, + PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&main_stack_context.mutex, + &main_stack_context.mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&main_stack_context.mutex, NULL); + assert (res == 0); +#endif + // lock the mutex, as we are currently running + res = pthread_mutex_lock (&main_stack_context.mutex); + assert (res == 0); + + current = &main_stack_context; + + grt_set_main_stack (&main_stack_context); +} + +//---------------------------------------------------------------------------- +static void* grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until mutex becomes available again. + // this happens when this stack is enabled for the first time + pthread_mutex_lock(&(myStack->mutex)); + + // run stack's function in endless loop + while(1) + { + INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//---------------------------------------------------------------------------- +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ + Stack_Type newStack; + int res; + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack = malloc (sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func = Func; + newStack->Arg = Arg; + + // create mutex +#if defined(__CYGWIN__) + res = pthread_mutexattr_init (&newStack->mxAttr); + assert (res == 0); + res = pthread_mutexattr_settype (&newStack->mxAttr, PTHREAD_MUTEX_DEFAULT); + assert (res == 0); + res = pthread_mutex_init (&newStack->mutex, &newStack->mxAttr); + assert (res == 0); +#else + res = pthread_mutex_init (&newStack->mutex, NULL); + assert (res == 0); +#endif + + // block the mutex, so that thread will blocked in grt_stack_loop + res = pthread_mutex_lock (&newStack->mutex); + assert (res == 0); + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + pthread_create (&newStack->thread, NULL, grt_stack_loop, newStack); + + return newStack; +} + +static int need_longjmp; +static int run_env_en; +static jmp_buf run_env; + +//---------------------------------------------------------------------------- +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ + int res; + INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + current = To; + + // unlock 'To' mutex. this will make the other thread either + // - starts for first time in grt_stack_loop + // - resumes at lock below + res = pthread_mutex_unlock (&To->mutex); + assert (res == 0); + + // block until 'From' mutex becomes available again + // as we are running, our mutex is locked and we block here + // when stacks are switched, with above unlock, we may proceed + res = pthread_mutex_lock (&From->mutex); + assert (res == 0); + + if (From == &main_stack_context && need_longjmp != 0) + longjmp (run_env, need_longjmp); +} + +//---------------------------------------------------------------------------- +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ + INFO("grt_stack_delete\n"); +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (!run_env_en) + return; + + if (current != &main_stack_context) + { + need_longjmp = val; + grt_stack_switch (&main_stack_context, current); + } + else + longjmp (run_env, val); +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + return res; +} + + +//---------------------------------------------------------------------------- + +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif /* WITH_GNAT_RUN_TIME */ + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/config/sparc.S b/src/translate/grt/config/sparc.S new file mode 100644 index 0000000..0ffe412 --- /dev/null +++ b/src/translate/grt/config/sparc.S @@ -0,0 +1,141 @@ +/* GRT stack implementation for x86. + 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. +*/ + .file "sparc.S" + + .section ".text" + + /* Stack structure is: + +4 : cur_length + +0 : cur_sp + -4 : return address + -8 : process function to be executed + -12: function argument + ... + -72: %sp + */ + + /* Function called to loop on the process. */ + .align 4 + .type grt_stack_loop,#function +grt_stack_loop: + ld [%sp + 64], %o1 + jmpl %o1 + 0, %o7 + ld [%sp + 68], %o0 + ba grt_stack_loop + nop + .size grt_stack_loop, . - grt_stack_loop + + /* function Stack_Create (Func : Address; Arg : Address) + return Stack_Type; */ + .align 4 + .global grt_stack_create + .type grt_stack_create,#function +grt_stack_create: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Allocate the stack, and exit in case of failure */ + call grt_stack_allocate + nop + cmp %o0, 0 + be .Ldone + nop + + /* Note: %o0 contains the address of the stack_context. This is + also the top of the stack. */ + + /* Prepare stack. */ + + /* The return function. */ + sethi %hi(grt_stack_loop - 8), %l2 + or %lo(grt_stack_loop - 8), %l2, %l2 + + /* Create a frame for grt_stack_loop. */ + sub %o0, (64 + 8), %l1 + + /* The function to be executed. */ + st %i0, [%l1 + 64] + /* The argument. */ + st %i1, [%l1 + 68] + + /* Create a frame for grt_stack_switch. */ + sub %l1, 64, %l0 + + /* Save frame pointer. */ + st %l1, [%l0 + 56] + /* Save return address. */ + st %l2, [%l0 + 60] + + /* Save stack pointer. */ + st %l0, [%o0] + +.Ldone: + ret + restore %o0, %g0, %o0 + .size grt_stack_create,. - grt_stack_create + + + .align 4 + .global grt_stack_switch + /* Arguments: TO, FROM. + Both are pointers to a stack_context. */ + .type grt_stack_switch,#function +grt_stack_switch: + /* Standard prologue. */ + save %sp,-80,%sp + + /* Flush and invalidate windows. + It is not clear wether the current window is saved or not, + therefore, I assume it is not. + */ + ta 3 + + /* Only IN registers %fp and %i7 (return address) must be saved. + Of course, I could use std/ldd, but it is not as clear + */ + /* Save current frame pointer. */ + st %fp, [%sp + 56] + /* Save return address. */ + st %i7, [%sp + 60] + + /* Save stack pointer. */ + st %sp, [%i1] + + /* Load stack pointer. */ + ld [%i0], %sp + + /* Load return address. */ + ld [%sp + 60], %i7 + /* Load frame pointer. */ + ld [%sp + 56], %fp + + /* Return. */ + ret + restore + .size grt_stack_switch, . - grt_stack_switch + + + .ident "Written by T.Gingold" diff --git a/src/translate/grt/config/teststack.c b/src/translate/grt/config/teststack.c new file mode 100644 index 0000000..6a6966d --- /dev/null +++ b/src/translate/grt/config/teststack.c @@ -0,0 +1,174 @@ +#include <stdlib.h> +#include <stdio.h> + +extern void grt_stack_init (void); +extern void grt_stack_switch (void *from, void *to); +extern void *grt_stack_create (void (*func)(void *), void *arg); + +int stack_size = 4096; +int stack_max_size = 8 * 4096; + +static void *stack1; +static void *stack2; +void *grt_stack_main_stack; + +void *grt_cur_proc; + +static int step; + +void +grt_overflow_error (void) +{ + abort (); +} + +void +grt_stack_error_null_access (void) +{ + abort (); +} + +void +grt_stack_error_memory_access (void) +{ + abort (); +} + +void +grt_stack_error_grow_failed (void) +{ + abort (); +} + +void +error (void) +{ + printf ("Test failure at step %d\n", step); + fflush (stdout); + exit (1); +} + +static void +func1 (void *ptr) +{ + if (ptr != (void *)1) + error (); + + if (step != 0) + error (); + + step = 1; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 5) + error (); + + step = 6; + + grt_stack_switch (grt_stack_main_stack, stack1); + + if (step != 7) + error (); + + step = 8; + + grt_stack_switch (stack2, stack1); + + if (step != 9) + error (); + + step = 10; + + grt_stack_switch (grt_stack_main_stack, stack1); + + error (); +} + +static void +func2 (void *ptr) +{ + if (ptr != (void *)2) + error (); + + if (step == 11) + { + step = 12; + + grt_stack_switch (grt_stack_main_stack, stack2); + + error (); + } + + if (step != 1) + error (); + + step = 2; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 3) + error (); + + step = 4; + + grt_stack_switch (grt_stack_main_stack, stack2); + + if (step != 8) + error (); + + step = 9; + + grt_stack_switch (stack1, stack2); +} + +int +main (void) +{ + grt_stack_init (); + + stack1 = grt_stack_create (&func1, (void *)1); + stack2 = grt_stack_create (&func2, (void *)2); + + step = 0; + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 1) + error (); + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 2) + error (); + + step = 3; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 4) + error (); + + step = 5; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 6) + error (); + + step = 7; + + grt_stack_switch (stack1, grt_stack_main_stack); + + if (step != 10) + error (); + + step = 11; + + grt_stack_switch (stack2, grt_stack_main_stack); + + if (step != 12) + error (); + + printf ("Test successful\n"); + return 0; +} diff --git a/src/translate/grt/config/times.c b/src/translate/grt/config/times.c new file mode 100644 index 0000000..9c0b4eb --- /dev/null +++ b/src/translate/grt/config/times.c @@ -0,0 +1,55 @@ +/* GRT C bindings for time. + 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. +*/ +#include <sys/times.h> +#include <unistd.h> + +int +grt_get_clk_tck (void) +{ + return sysconf (_SC_CLK_TCK); +} + +void +grt_get_times (int *wall, int *user, int *sys) +{ + clock_t res; + struct tms buf; + + res = times (&buf); + if (res == (clock_t)-1) + { + *wall = 0; + *user = 0; + *sys = 0; + } + else + { + *wall = res; + *user = buf.tms_utime; + *sys = buf.tms_stime; + } +} + diff --git a/src/translate/grt/config/win32.c b/src/translate/grt/config/win32.c new file mode 100644 index 0000000..35322ba --- /dev/null +++ b/src/translate/grt/config/win32.c @@ -0,0 +1,265 @@ +/* GRT stack implementation for Win32 using fibers. + Copyright (C) 2005 - 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. +*/ + +#include <windows.h> +#include <stdio.h> +#include <setjmp.h> +#include <assert.h> +#include <excpt.h> + +static EXCEPTION_DISPOSITION +ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame, + struct _CONTEXT* ContextRecord, + void *DispatcherContext); + +struct exception_registration +{ + struct exception_registration *prev; + void *handler; +}; + +struct stack_type +{ + LPVOID fiber; // Win fiber. + void (*func)(void *); // Function + void *arg; // Function argument. +}; + +static struct stack_type main_stack_context; +static struct stack_type *current; +extern void grt_set_main_stack (struct stack_type *stack); + +void grt_stack_init(void) +{ + main_stack_context.fiber = ConvertThreadToFiber (NULL); + if (main_stack_context.fiber == NULL) + { + fprintf (stderr, "convertThreadToFiber failed (err=%lu)\n", + GetLastError ()); + abort (); + } + grt_set_main_stack (&main_stack_context); + current = &main_stack_context; +} + +static VOID __stdcall +grt_stack_loop (void *v_stack) +{ + struct stack_type *stack = (struct stack_type *)v_stack; + struct exception_registration er; + struct exception_registration *prev; + + /* Get current handler. */ + asm ("mov %%fs:(0),%0" : "=r" (prev)); + + /* Build regisration. */ + er.prev = prev; + er.handler = ghdl_SEH_handler; + + /* Register. */ + asm ("mov %0,%%fs:(0)" : : "r" (&er)); + + while (1) + { + (*stack->func)(stack->arg); + } +} + +struct stack_type * +grt_stack_create (void (*func)(void *), void *arg) +{ + struct stack_type *res; + + res = malloc (sizeof (struct stack_type)); + if (res == NULL) + return NULL; + res->func = func; + res->arg = arg; + res->fiber = CreateFiber (0, &grt_stack_loop, res); + if (res->fiber == NULL) + { + free (res); + return NULL; + } + return res; +} + +static int run_env_en; +static jmp_buf run_env; +static int need_longjmp; + +void +grt_stack_switch (struct stack_type *to, struct stack_type *from) +{ + assert (current == from); + current = to; + SwitchToFiber (to->fiber); + if (from == &main_stack_context && need_longjmp) + { + /* We returned to do the longjump. */ + current = &main_stack_context; + longjmp (run_env, need_longjmp); + } +} + +void +grt_stack_delete (struct stack_type *stack) +{ + DeleteFiber (stack->fiber); + stack->fiber = NULL; +} + +void +__ghdl_maybe_return_via_longjump (int val) +{ + if (!run_env_en) + return; + + if (current != &main_stack_context) + { + /* We are allowed to jump only in the same stack. + First switch back to the main thread. */ + need_longjmp = val; + SwitchToFiber (main_stack_context.fiber); + } + else + longjmp (run_env, val); +} + +extern void grt_stack_error_grow_failed (void); +extern void grt_stack_error_null_access (void); +extern void grt_stack_error_memory_access (void); +extern void grt_overflow_error (void); + +static EXCEPTION_DISPOSITION +ghdl_SEH_handler (struct _EXCEPTION_RECORD* ExceptionRecord, + void *EstablisherFrame, + struct _CONTEXT* ContextRecord, + void *DispatcherContext) +{ + const char *msg = ""; + + switch (ExceptionRecord->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: + if (ExceptionRecord->ExceptionInformation[1] == 0) + grt_stack_error_null_access (); + else + grt_stack_error_memory_access (); + break; + + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + msg = "floating point error"; + break; + + case EXCEPTION_INT_DIVIDE_BY_ZERO: + msg = "division by 0"; + break; + + case EXCEPTION_INT_OVERFLOW: + grt_overflow_error (); + break; + + case EXCEPTION_STACK_OVERFLOW: + msg = "stack overflow"; + break; + + default: + msg = "unknown reason"; + break; + } + + /* FIXME: is it correct? */ + fprintf (stderr, "exception raised: %s\n", msg); + + __ghdl_maybe_return_via_longjump (1); + return 0; /* This is never reached, avoid compiler warning */ +} + +int +__ghdl_run_through_longjump (int (*func)(void)) +{ + int res; + struct exception_registration er; + struct exception_registration *prev; + + /* Get current handler. */ + asm ("mov %%fs:(0),%0" : "=r" (prev)); + + /* Build regisration. */ + er.prev = prev; + er.handler = ghdl_SEH_handler; + + /* Register. */ + asm ("mov %0,%%fs:(0)" : : "r" (&er)); + + run_env_en = 1; + res = setjmp (run_env); + if (res == 0) + res = (*func)(); + run_env_en = 0; + + /* Restore. */ + asm ("mov %0,%%fs:(0)" : : "r" (prev)); + + return res; +} + +#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/translate/grt/config/win32thr.c b/src/translate/grt/config/win32thr.c new file mode 100644 index 0000000..bcebc49 --- /dev/null +++ b/src/translate/grt/config/win32thr.c @@ -0,0 +1,167 @@ +/* GRT stack implementation for Win32 + Copyright (C) 2004, 2005 Felix Bertram. + + 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. +*/ +//----------------------------------------------------------------------------- +// Project: GHDL - VHDL Simulator +// Description: Win32 port of stacks package +// Note: Tristan's original i386/Linux used assembly-code +// to manually switch stacks for performance reasons. +// History: 2004feb09, FB, created. +//----------------------------------------------------------------------------- + +#include <windows.h> +//#include <pthread.h> +//#include <stdlib.h> +//#include <stdio.h> + + +//#define INFO printf +#define INFO (void) + +// GHDL names an endless loop calling FUNC with ARG a 'stack' +// at a given time, only one stack may be 'executed' +typedef struct +{ HANDLE thread; // stack's thread + HANDLE mutex; // mutex to suspend/resume thread + void (*Func)(void*); // stack's FUNC + void* Arg; // ARG passed to FUNC +} Stack_Type_t, *Stack_Type; + + +static Stack_Type_t main_stack_context; +extern void grt_set_main_stack (Stack_Type_t *stack); + +//------------------------------------------------------------------------------ +void grt_stack_init(void) +// Initialize the stacks package. +// This may adjust stack sizes. +// Must be called after grt.options.decode. +// => procedure Stack_Init; +{ INFO("grt_stack_init\n"); + INFO(" main_stack_context=0x%08x\n", &main_stack_context); + + // create event. reset event, as we are currently running + main_stack_context.mutex = CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + grt_set_main_stack (&main_stack_context); +} + +//------------------------------------------------------------------------------ +static unsigned long __stdcall grt_stack_loop(void* pv_myStack) +{ + Stack_Type myStack= (Stack_Type)pv_myStack; + + INFO("grt_stack_loop\n"); + + INFO(" myStack=0x%08x\n", myStack); + + // block until event becomes set again. + // this happens when this stack is enabled for the first time + WaitForSingleObject(myStack->mutex, INFINITE); + + // run stack's function in endless loop + while(1) + { INFO(" call 0x%08x with 0x%08x\n", myStack->Func, myStack->Arg); + myStack->Func(myStack->Arg); + } + + // we never get here... + return 0; +} + +//------------------------------------------------------------------------------ +Stack_Type grt_stack_create(void* Func, void* Arg) +// Create a new stack, which on first execution will call FUNC with +// an argument ARG. +// => function Stack_Create (Func : Address; Arg : Address) return Stack_Type; +{ Stack_Type newStack; + DWORD m_IDThread; // Thread's ID (dummy) + + INFO("grt_stack_create\n"); + INFO(" call 0x%08x with 0x%08x\n", Func, Arg); + + newStack= malloc(sizeof(Stack_Type_t)); + + // init function and argument + newStack->Func= Func; + newStack->Arg= Arg; + + // create event. reset event, so that thread will blocked in grt_stack_loop + newStack->mutex= CreateEvent(NULL, // lpsa + FALSE, // fManualReset + FALSE, // fInitialState + NULL); // lpszEventName + + INFO(" newStack=0x%08x\n", newStack); + + // create thread, which executes grt_stack_loop + newStack->thread= CreateThread(NULL, // lpsa + 0, // cbStack + grt_stack_loop, // lpStartAddr + newStack, // lpvThreadParm + 0, // fdwCreate + &m_IDThread); // lpIDThread + + return newStack; +} + +//------------------------------------------------------------------------------ +void grt_stack_switch(Stack_Type To, Stack_Type From) +// Resume stack TO and save the current context to the stack pointed by +// CUR. +// => procedure Stack_Switch (To : Stack_Type; From : Stack_Type); +{ INFO("grt_stack_switch\n"); + INFO(" from 0x%08x to 0x%08x\n", From, To); + + // set 'To' event. this will make the other thread either + // - start for first time in grt_stack_loop + // - resume at WaitForSingleObject below + SetEvent(To->mutex); + + // block until 'From' event becomes set again + // as we are running, our event is reset and we block here + // when stacks are switched, with above SetEvent, we may proceed + WaitForSingleObject(From->mutex, INFINITE); +} + +//------------------------------------------------------------------------------ +void grt_stack_delete(Stack_Type Stack) +// Delete stack STACK, which must not be currently executed. +// => procedure Stack_Delete (Stack : Stack_Type); +{ INFO("grt_stack_delete\n"); +} + +//---------------------------------------------------------------------------- +#ifndef WITH_GNAT_RUN_TIME +void __gnat_raise_storage_error(void) +{ + abort (); +} + +void __gnat_raise_program_error(void) +{ + abort (); +} +#endif + +//---------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/ghdl_main.adb b/src/translate/grt/ghdl_main.adb new file mode 100644 index 0000000..ce5b67d --- /dev/null +++ b/src/translate/grt/ghdl_main.adb @@ -0,0 +1,61 @@ +-- GHDL Run Time (GRT) entry point. +-- 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 Ada.Unchecked_Conversion; +with Grt.Options; use Grt.Options; +with Grt.Main; +with Grt.Types; use Grt.Types; + +-- Some files are only referenced from compiled code. With it here so that +-- they get compiled during build (and elaborated). +pragma Warnings (Off); +with Grt.Rtis_Binding; +with Grt.Std_Logic_1164; +pragma Warnings (On); + + +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer +is + -- Grt_Init corresponds to the 'adainit' subprogram for grt. + procedure Grt_Init; + pragma Import (C, Grt_Init, "grt_init"); + + function To_Argv_Type is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Grt.Options.Argv_Type); + + Default_Progname : constant String := "ghdl_design" & NUL; +begin + if Argc > 0 then + Grt.Options.Progname := To_Argv_Type (Argv)(0); + else + Grt.Options.Progname := To_Ghdl_C_String (Default_Progname'Address); + end if; + Grt.Options.Argc := Argc; + Grt.Options.Argv := To_Argv_Type (Argv); + + Grt_Init; + Grt.Main.Run; + return 0; +end Ghdl_Main; diff --git a/src/translate/grt/ghdl_main.ads b/src/translate/grt/ghdl_main.ads new file mode 100644 index 0000000..88d181a --- /dev/null +++ b/src/translate/grt/ghdl_main.ads @@ -0,0 +1,33 @@ +-- GHDL Run Time (GRT) entry point. +-- 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; + +-- 'main' function for grt. +-- Contrary to the C main function, ARGC can be 0 (in this case a fake argv[0] +-- is used). +function Ghdl_Main (Argc : Integer; Argv : System.Address) + return Integer; +pragma Export (C, Ghdl_Main, "ghdl_main"); + diff --git a/src/translate/grt/ghwdump.c b/src/translate/grt/ghwdump.c new file mode 100644 index 0000000..4affc2b --- /dev/null +++ b/src/translate/grt/ghwdump.c @@ -0,0 +1,195 @@ +/* Display a GHDL Wavefile for debugging. + Copyright (C) 2005 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. +*/ + +#include <stdio.h> +#include <stdint.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> + +#include "ghwlib.h" + +static const char *progname; +void +usage (void) +{ + printf ("usage: %s [OPTIONS] FILEs...\n", progname); + printf ("Options are:\n" + " -t display types\n" + " -h display hierarchy\n" + " -T display time\n" + " -s display signals (and time)\n" + " -l display list of sections\n" + " -v verbose\n"); +} + +int +main (int argc, char **argv) +{ + int i; + int flag_disp_types; + int flag_disp_hierarchy; + int flag_disp_time; + int flag_disp_signals; + int flag_list; + int flag_verbose; + int eof; + enum ghw_sm_type sm; + + progname = argv[0]; + flag_disp_types = 0; + flag_disp_hierarchy = 0; + flag_disp_time = 0; + flag_disp_signals = 0; + flag_list = 0; + flag_verbose = 0; + + while (1) + { + int c; + + c = getopt (argc, argv, "thTslv"); + if (c == -1) + break; + switch (c) + { + case 't': + flag_disp_types = 1; + break; + case 'h': + flag_disp_hierarchy = 1; + break; + case 'T': + flag_disp_time = 1; + break; + case 's': + flag_disp_signals = 1; + flag_disp_time = 1; + break; + case 'l': + flag_list = 1; + break; + case 'v': + flag_verbose++; + break; + default: + usage (); + exit (2); + } + } + + if (optind >= argc) + { + usage (); + return 1; + } + + for (i = optind; i < argc; i++) + { + struct ghw_handler h; + struct ghw_handler *hp = &h; + + hp->flag_verbose = flag_verbose; + + if (ghw_open (hp, argv[i]) != 0) + { + fprintf (stderr, "cannot open ghw file %s\n", argv[i]); + return 1; + } + if (flag_list) + { + while (1) + { + int section; + + section = ghw_read_section (hp); + if (section == -2) + { + printf ("eof of file\n"); + break; + } + else if (section < 0) + { + printf ("Error in file\n"); + break; + } + else if (section == 0) + { + printf ("Unknown section\n"); + break; + } + printf ("Section %s\n", ghw_sections[section].name); + if ((*ghw_sections[section].handler)(hp) < 0) + break; + } + } + else + { + if (ghw_read_base (hp) < 0) + { + fprintf (stderr, "cannot read ghw file\n"); + return 2; + } + if (0) + { + int i; + printf ("String table:\n"); + + for (i = 1; i < hp->nbr_str; i++) + printf (" %s\n", hp->str_table[i]); + } + if (flag_disp_types) + ghw_disp_types (hp); + if (flag_disp_hierarchy) + ghw_disp_hie (hp, hp->hie); + +#if 1 + sm = ghw_sm_init; + eof = 0; + while (!eof) + { + switch (ghw_read_sm (hp, &sm)) + { + case ghw_res_snapshot: + case ghw_res_cycle: + if (flag_disp_time) + printf ("Time is %lld fs\n", hp->snap_time); + if (flag_disp_signals) + ghw_disp_values (hp); + break; + case ghw_res_eof: + eof = 1; + break; + default: + abort (); + } + } + +#else + if (ghw_read_dump (hp) < 0) + { + fprintf (stderr, "error in ghw dump\n"); + return 3; + } +#endif + } + ghw_close (&h); + } + return 0; +} diff --git a/src/translate/grt/ghwlib.c b/src/translate/grt/ghwlib.c new file mode 100644 index 0000000..2db63d9 --- /dev/null +++ b/src/translate/grt/ghwlib.c @@ -0,0 +1,1746 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 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. +*/ + +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> + +#include "ghwlib.h" + +int +ghw_open (struct ghw_handler *h, const char *filename) +{ + char hdr[16]; + + h->stream = fopen (filename, "rb"); + if (h->stream == NULL) + return -1; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + /* Check magic. */ + if (memcmp (hdr, "GHDLwave\n", 9) != 0) + return -2; + /* Check version. */ + if (hdr[9] != 16 + || hdr[10] != 0) + return -2; + h->version = hdr[11]; + if (h->version > 1) + return -3; + if (hdr[12] == 1) + h->word_be = 0; + else if (hdr[12] == 2) + h->word_be = 1; + else + return -4; +#if 0 + /* Endianness. */ + { + int endian; + union { unsigned char b[4]; uint32_t i;} v; + v.i = 0x11223344; + if (v.b[0] == 0x11) + endian = 2; + else if (v.b[0] == 0x44) + endian = 1; + else + return -3; + + if (hdr[12] != 1 && hdr[12] != 2) + return -3; + if (hdr[12] != endian) + h->swap_word = 1; + else + h->swap_word = 0; + } +#endif + h->word_len = hdr[13]; + h->off_len = hdr[14]; + + if (hdr[15] != 0) + return -5; + + h->hie = NULL; + return 0; +} + +int32_t +ghw_get_i32 (struct ghw_handler *h, unsigned char *b) +{ + if (h->word_be) + return (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0); + else + return (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0); +} + +int64_t +ghw_get_i64 (struct ghw_handler *ghw_h, unsigned char *b) +{ + int l, h; + + if (ghw_h->word_be) + { + h = (b[0] << 24) | (b[1] << 16) | (b[2] << 8) | (b[3] << 0); + l = (b[4] << 24) | (b[5] << 16) | (b[6] << 8) | (b[7] << 0); + } + else + { + l = (b[3] << 24) | (b[2] << 16) | (b[1] << 8) | (b[0] << 0); + h = (b[7] << 24) | (b[6] << 16) | (b[5] << 8) | (b[4] << 0); + } + return (((int64_t)h) << 32) | l; +} + +int +ghw_read_byte (struct ghw_handler *h, unsigned char *res) +{ + int v; + + v = fgetc (h->stream); + if (v == EOF) + return -1; + *res = v; + return 0; +} + +int +ghw_read_uleb128 (struct ghw_handler *h, uint32_t *res) +{ + unsigned int r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= (v & 0x7f) << off; + if ((v & 0x80) == 0) + break; + off += 7; + } + *res = r; + return 0; +} + +int +ghw_read_sleb128 (struct ghw_handler *h, int32_t *res) +{ + int32_t r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= ((int32_t)(v & 0x7f)) << off; + off += 7; + if ((v & 0x80) == 0) + { + if ((v & 0x40) && off < 32) + r |= -1 << off; + break; + } + } + *res = r; + return 0; +} + +int +ghw_read_lsleb128 (struct ghw_handler *h, int64_t *res) +{ + static const int64_t r_mask = -1; + int64_t r = 0; + unsigned int off = 0; + + while (1) + { + int v = fgetc (h->stream); + if (v == EOF) + return -1; + r |= ((int64_t)(v & 0x7f)) << off; + off += 7; + if ((v & 0x80) == 0) + { + if ((v & 0x40) && off < 64) + r |= r_mask << off; + break; + } + } + *res = r; + return 0; +} + +int +ghw_read_f64 (struct ghw_handler *h, double *res) +{ + /* FIXME: handle byte order. */ + if (fread (res, sizeof (*res), 1, h->stream) != 1) + return -1; + return 0; +} + +const char * +ghw_read_strid (struct ghw_handler *h) +{ + unsigned int id; + if (ghw_read_uleb128 (h, &id) != 0) + return NULL; + return h->str_table[id]; +} + +union ghw_type * +ghw_read_typeid (struct ghw_handler *h) +{ + unsigned int id; + if (ghw_read_uleb128 (h, &id) != 0) + return NULL; + return h->types[id - 1]; +} + +union ghw_range * +ghw_read_range (struct ghw_handler *h) +{ + int t = fgetc (h->stream); + if (t == EOF) + return NULL; + switch (t & 0x7f) + { + case ghdl_rtik_type_b2: + { + struct ghw_range_b2 *r; + r = malloc (sizeof (struct ghw_range_b2)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_byte (h, &r->left) != 0) + return NULL; + if (ghw_read_byte (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_e8: + { + struct ghw_range_e8 *r; + r = malloc (sizeof (struct ghw_range_e8)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_byte (h, &r->left) != 0) + return NULL; + if (ghw_read_byte (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + { + struct ghw_range_i32 *r; + r = malloc (sizeof (struct ghw_range_i32)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_sleb128 (h, &r->left) != 0) + return NULL; + if (ghw_read_sleb128 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_i64: + case ghdl_rtik_type_p64: + { + struct ghw_range_i64 *r; + r = malloc (sizeof (struct ghw_range_i64)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_lsleb128 (h, &r->left) != 0) + return NULL; + if (ghw_read_lsleb128 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + case ghdl_rtik_type_f64: + { + struct ghw_range_f64 *r; + r = malloc (sizeof (struct ghw_range_f64)); + r->kind = t & 0x7f; + r->dir = (t & 0x80) != 0; + if (ghw_read_f64 (h, &r->left) != 0) + return NULL; + if (ghw_read_f64 (h, &r->right) != 0) + return NULL; + return (union ghw_range *)r; + } + default: + fprintf (stderr, "ghw_read_range: type %d unhandled\n", t & 0x7f); + return NULL; + } +} + +int +ghw_read_str (struct ghw_handler *h) +{ + unsigned char hdr[12]; + int i; + char *p; + int prev_len; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->nbr_str = ghw_get_i32 (h, &hdr[4]); + h->nbr_str++; + h->str_size = ghw_get_i32 (h, &hdr[8]); + h->str_table = (char **)malloc ((h->nbr_str + 1) * sizeof (char *)); + h->str_content = (char *)malloc (h->str_size + h->nbr_str + 1); + + if (h->flag_verbose) + { + printf ("Number of strings: %d\n", h->nbr_str - 1); + printf ("String table size: %d\n", h->str_size); + } + + h->str_table[0] = "<anon>"; + p = h->str_content; + prev_len = 0; + for (i = 1; i < h->nbr_str; i++) + { + int j; + int c; + char *prev; + int sh; + + h->str_table[i] = p; + prev = h->str_table[i - 1]; + for (j = 0; j < prev_len; j++) + *p++ = prev[j]; + + while (1) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + if ((c >= 0 && c <= 31) + || (c >= 128 && c <= 159)) + break; + *p++ = c; + } + *p++ = 0; + + if (h->flag_verbose > 1) + printf (" string %d (pl=%d): %s\n", i, prev_len, h->str_table[i]); + + prev_len = c & 0x1f; + sh = 5; + while (c >= 128) + { + c = fgetc (h->stream); + if (c == EOF) + return -1; + prev_len |= (c & 0x1f) << sh; + sh += 5; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOS", 4) != 0) + return -1; + return 0; +} + +union ghw_type * +ghw_get_base_type (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + return t; + case ghdl_rtik_subtype_scalar: + return t->ss.base; + case ghdl_rtik_subtype_array: + return (union ghw_type*)(t->sa.base); + default: + fprintf (stderr, "ghw_get_base_type: cannot handle type %d\n", t->kind); + abort (); + } +} + +int +get_nbr_elements (union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + case ghdl_rtik_subtype_scalar: + return 1; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + return t->sa.nbr_el; + case ghdl_rtik_type_record: + return t->rec.nbr_el; + default: + fprintf (stderr, "get_nbr_elements: unhandled type %d\n", t->kind); + abort (); + } +} + +int +get_range_length (union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_i32: + if (rng->i32.dir) + return (rng->i32.left - rng->i32.right + 1); + else + return (rng->i32.right - rng->i32.left + 1); + default: + fprintf (stderr, "get_range_length: unhandled kind %d\n", rng->kind); + abort (); + } +} + +int +ghw_read_type (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->nbr_types = ghw_get_i32 (h, &hdr[4]); + h->types = (union ghw_type **) + malloc (h->nbr_types * sizeof (union ghw_type *)); + + for (i = 0; i < h->nbr_types; i++) + { + int t; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + /* printf ("type[%d]= %d\n", i, t); */ + switch (t) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e; + int j; + + e = malloc (sizeof (struct ghw_type_enum)); + e->kind = t; + e->wkt = ghw_wkt_unknown; + e->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &e->nbr) != 0) + return -1; + e->lits = (const char **) malloc (e->nbr * sizeof (char *)); + if (h->flag_verbose > 1) + printf ("enum %s:", e->name); + for (j = 0; j < e->nbr; j++) + { + e->lits[j] = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf (" %s", e->lits[j]); + } + if (h->flag_verbose > 1) + printf ("\n"); + h->types[i] = (union ghw_type *)e; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_i64: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *sc; + + sc = malloc (sizeof (struct ghw_type_scalar)); + sc->kind = t; + sc->name = ghw_read_strid (h); + if (h->flag_verbose > 1) + printf ("scalar: %s\n", sc->name); + h->types[i] = (union ghw_type *)sc; + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + struct ghw_type_physical *ph; + + ph = malloc (sizeof (struct ghw_type_physical)); + ph->kind = t; + ph->name = ghw_read_strid (h); + if (h->version == 0) + ph->nbr_units = 0; + else + { + int i; + + if (ghw_read_uleb128 (h, &ph->nbr_units) != 0) + return -1; + ph->units = malloc (ph->nbr_units * sizeof (struct ghw_unit)); + for (i = 0; i < ph->nbr_units; i++) + { + ph->units[i].name = ghw_read_strid (h); + if (ghw_read_lsleb128 (h, &ph->units[i].val) < 0) + return -1; + } + } + if (h->flag_verbose > 1) + printf ("physical: %s\n", ph->name); + h->types[i] = (union ghw_type *)ph; + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *ss; + + ss = malloc (sizeof (struct ghw_subtype_scalar)); + ss->kind = t; + ss->name = ghw_read_strid (h); + ss->base = ghw_read_typeid (h); + ss->rng = ghw_read_range (h); + if (h->flag_verbose > 1) + printf ("subtype scalar: %s\n", ss->name); + h->types[i] = (union ghw_type *)ss; + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *arr; + int j; + + arr = malloc (sizeof (struct ghw_type_array)); + arr->kind = t; + arr->name = ghw_read_strid (h); + arr->el = ghw_read_typeid (h); + if (ghw_read_uleb128 (h, &arr->nbr_dim) != 0) + return -1; + arr->dims = (union ghw_type **) + malloc (arr->nbr_dim * sizeof (union ghw_type *)); + for (j = 0; j < arr->nbr_dim; j++) + arr->dims[j] = ghw_read_typeid (h); + if (h->flag_verbose > 1) + printf ("array: %s\n", arr->name); + h->types[i] = (union ghw_type *)arr; + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *sa; + int j; + int nbr_el; + + sa = malloc (sizeof (struct ghw_subtype_array)); + sa->kind = t; + sa->name = ghw_read_strid (h); + sa->base = (struct ghw_type_array *)ghw_read_typeid (h); + nbr_el = get_nbr_elements (sa->base->el); + sa->rngs = malloc (sa->base->nbr_dim * sizeof (union ghw_range *)); + for (j = 0; j < sa->base->nbr_dim; j++) + { + sa->rngs[j] = ghw_read_range (h); + nbr_el *= get_range_length (sa->rngs[j]); + } + sa->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("subtype array: %s (nbr_el=%d)\n", sa->name, sa->nbr_el); + h->types[i] = (union ghw_type *)sa; + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *rec; + int j; + int nbr_el; + + rec = malloc (sizeof (struct ghw_type_record)); + rec->kind = t; + rec->name = ghw_read_strid (h); + if (ghw_read_uleb128 (h, &rec->nbr_fields) != 0) + return -1; + rec->el = malloc + (rec->nbr_fields * sizeof (struct ghw_record_element)); + nbr_el = 0; + for (j = 0; j < rec->nbr_fields; j++) + { + rec->el[j].name = ghw_read_strid (h); + rec->el[j].type = ghw_read_typeid (h); + nbr_el += get_nbr_elements (rec->el[j].type); + } + rec->nbr_el = nbr_el; + if (h->flag_verbose > 1) + printf ("record type: %s (nbr_el=%d)\n", rec->name, rec->nbr_el); + h->types[i] = (union ghw_type *)rec; + } + break; + default: + fprintf (stderr, "ghw_read_type: unknown type %d\n", t); + return -1; + } + } + if (fgetc (h->stream) != 0) + return -1; + return 0; +} + +int +ghw_read_wk_types (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + + while (1) + { + int t; + union ghw_type *tid; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + else if (t == 0) + break; + + tid = ghw_read_typeid (h); + if (tid->kind == ghdl_rtik_type_b2 + || tid->kind == ghdl_rtik_type_e8) + { + if (h->flag_verbose > 0) + printf ("%s: wkt=%d\n", tid->en.name, t); + tid->en.wkt = t; + } + } + return 0; +} + +void +ghw_disp_typename (struct ghw_handler *h, union ghw_type *t) +{ + printf ("%s", t->common.name); +} + +/* Read a signal composed of severals elements. */ +int +ghw_read_signal (struct ghw_handler *h, unsigned int *sigs, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + case ghdl_rtik_type_e32: + case ghdl_rtik_subtype_scalar: + { + unsigned int sig_el; + + if (ghw_read_uleb128 (h, &sig_el) < 0) + return -1; + *sigs = sig_el; + if (sig_el >= h->nbr_sigs) + abort (); + if (h->sigs[sig_el].type == NULL) + h->sigs[sig_el].type = ghw_get_base_type (t); + } + return 0; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + int i; + int stride; + int len; + + len = t->sa.nbr_el; + stride = get_nbr_elements (t->sa.base->el); + + for (i = 0; i < len; i += stride) + if (ghw_read_signal (h, &sigs[i], t->sa.base->el) < 0) + return -1; + } + return 0; + case ghdl_rtik_type_record: + { + int i; + int off; + + off = 0; + for (i = 0; i < t->rec.nbr_fields; i++) + { + if (ghw_read_signal (h, &sigs[off], t->rec.el[i].type) < 0) + return -1; + off += get_nbr_elements (t->rec.el[i].type); + } + } + return 0; + default: + fprintf (stderr, "ghw_read_signal: type kind %d unhandled\n", t->kind); + abort (); + } +} + + +int +ghw_read_value (struct ghw_handler *h, + union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->b2 = v; + } + break; + case ghdl_rtik_type_e8: + { + int v; + v = fgetc (h->stream); + if (v == EOF) + return -1; + val->e8 = v; + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + { + int32_t v; + if (ghw_read_sleb128 (h, &v) < 0) + return -1; + val->i32 = v; + } + break; + case ghdl_rtik_type_f64: + { + double v; + if (ghw_read_f64 (h, &v) < 0) + return -1; + val->f64 = v; + } + break; + case ghdl_rtik_type_p64: + { + int64_t v; + if (ghw_read_lsleb128 (h, &v) < 0) + return -1; + val->i64 = v; + } + break; + default: + fprintf (stderr, "read_value: cannot handle format %d\n", type->kind); + abort (); + } + return 0; +} + +int +ghw_read_hie (struct ghw_handler *h) +{ + unsigned char hdr[16]; + int nbr_scopes; + int nbr_sigs; + int i; + struct ghw_hie *blk; + struct ghw_hie **last; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + nbr_scopes = ghw_get_i32 (h, &hdr[4]); + /* Number of declared signals (which may be composite). */ + nbr_sigs = ghw_get_i32 (h, &hdr[8]); + /* Number of basic signals. */ + h->nbr_sigs = ghw_get_i32 (h, &hdr[12]); + + if (h->flag_verbose) + printf ("%d scopes, %d signals, %d signal elements\n", + nbr_scopes, nbr_sigs, h->nbr_sigs); + + blk = (struct ghw_hie *)malloc (sizeof (struct ghw_hie)); + blk->kind = ghw_hie_design; + blk->name = NULL; + blk->parent = NULL; + blk->brother = NULL; + blk->u.blk.child = NULL; + + last = &blk->u.blk.child; + h->hie = blk; + + h->nbr_sigs++; + h->sigs = (struct ghw_sig *) malloc (h->nbr_sigs * sizeof (struct ghw_sig)); + memset (h->sigs, 0, h->nbr_sigs * sizeof (struct ghw_sig)); + + while (1) + { + int t; + struct ghw_hie *el; + unsigned int str; + + t = fgetc (h->stream); + if (t == EOF) + return -1; + if (t == 0) + break; + + if (t == ghw_hie_eos) + { + blk = blk->parent; + if (blk->u.blk.child == NULL) + last = &blk->u.blk.child; + else + { + struct ghw_hie *l = blk->u.blk.child; + while (l->brother != NULL) + l = l->brother; + last = &l->brother; + } + + continue; + } + + el = (struct ghw_hie *) malloc (sizeof (struct ghw_hie)); + el->kind = t; + el->parent = blk; + el->brother = NULL; + + /* Link. */ + *last = el; + last = &el->brother; + + /* Read name. */ + if (ghw_read_uleb128 (h, &str) != 0) + return -1; + el->name = h->str_table[str]; + + switch (t) + { + case ghw_hie_eoh: + case ghw_hie_design: + case ghw_hie_eos: + /* Should not be here. */ + abort (); + case ghw_hie_process: + break; + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_generic: + case ghw_hie_package: + /* Create a block. */ + el->u.blk.child = NULL; + + if (t == ghw_hie_generate_for) + { + el->u.blk.iter_type = ghw_read_typeid (h); + el->u.blk.iter_value = malloc (sizeof (union ghw_val)); + if (ghw_read_value (h, el->u.blk.iter_value, + el->u.blk.iter_type) < 0) + return -1; + } + blk = el; + last = &el->u.blk.child; + break; + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + /* For a signal, read type. */ + { + int nbr_el; + unsigned int *sigs; + + el->u.sig.type = ghw_read_typeid (h); + nbr_el = get_nbr_elements (el->u.sig.type); + sigs = (unsigned int *) malloc + ((nbr_el + 1) * sizeof (unsigned int)); + el->u.sig.sigs = sigs; + /* Last element is NULL. */ + sigs[nbr_el] = 0; + + if (h->flag_verbose > 1) + printf ("signal %s: %d el [", el->name, nbr_el); + if (ghw_read_signal (h, sigs, el->u.sig.type) < 0) + return -1; + if (h->flag_verbose > 1) + { + int i; + for (i = 0; i < nbr_el; i++) + printf (" #%u", sigs[i]); + printf ("]\n"); + } + } + break; + default: + fprintf (stderr, "ghw_read_hie: unhandled kind %d\n", t); + abort (); + } + } + + /* Allocate values. */ + for (i = 0; i < h->nbr_sigs; i++) + if (h->sigs[i].type != NULL) + h->sigs[i].val = (union ghw_val *) malloc (sizeof (union ghw_val)); + return 0; +} + +const char * +ghw_get_hie_name (struct ghw_hie *h) +{ + switch (h->kind) + { + case ghw_hie_eoh: + return "eoh"; + case ghw_hie_design: + return "design"; + case ghw_hie_block: + return "block"; + case ghw_hie_generate_if: + return "generate-if"; + case ghw_hie_generate_for: + return "generate-for"; + case ghw_hie_instance: + return "instance"; + case ghw_hie_package: + return "package"; + case ghw_hie_process: + return "process"; + case ghw_hie_generic: + return "generic"; + case ghw_hie_eos: + return "eos"; + case ghw_hie_signal: + return "signal"; + case ghw_hie_port_in: + return "port-in"; + case ghw_hie_port_out: + return "port-out"; + case ghw_hie_port_inout: + return "port-inout"; + case ghw_hie_port_buffer: + return "port-buffer"; + case ghw_hie_port_linkage: + return "port-linkage"; + default: + return "??"; + } +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type); + +void +ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top) +{ + int i; + int indent; + struct ghw_hie *hie; + struct ghw_hie *n; + + hie = top; + indent = 0; + + while (1) + { + for (i = 0; i < indent; i++) + fputc (' ', stdout); + printf ("%s", ghw_get_hie_name (hie)); + + switch (hie->kind) + { + case ghw_hie_design: + case ghw_hie_block: + case ghw_hie_generate_if: + case ghw_hie_generate_for: + case ghw_hie_instance: + case ghw_hie_process: + case ghw_hie_package: + if (hie->name) + printf (" %s", hie->name); + if (hie->kind == ghw_hie_generate_for) + { + printf ("("); + ghw_disp_value (hie->u.blk.iter_value, hie->u.blk.iter_type); + printf (")"); + } + n = hie->u.blk.child; + if (n == NULL) + n = hie->brother; + else + indent++; + break; + case ghw_hie_generic: + case ghw_hie_eos: + abort (); + case ghw_hie_signal: + case ghw_hie_port_in: + case ghw_hie_port_out: + case ghw_hie_port_inout: + case ghw_hie_port_buffer: + case ghw_hie_port_linkage: + { + unsigned int *sigs; + + printf (" %s: ", hie->name); + ghw_disp_typename (h, hie->u.sig.type); + for (sigs = hie->u.sig.sigs; *sigs != 0; sigs++) + printf (" #%u", *sigs); + n = hie->brother; + } + break; + default: + abort (); + } + printf ("\n"); + + while (n == NULL) + { + if (hie->parent == NULL) + return; + hie = hie->parent; + indent--; + n = hie->brother; + } + hie = n; + } +} + +int +ghw_read_eoh (struct ghw_handler *h) +{ + return 0; +} + + +int +ghw_read_base (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "STR", 4) == 0) + res = ghw_read_str (h); + else if (memcmp (hdr, "HIE", 4) == 0) + res = ghw_read_hie (h); + else if (memcmp (hdr, "TYP", 4) == 0) + res = ghw_read_type (h); + else if (memcmp (hdr, "WKT", 4) == 0) + res = ghw_read_wk_types (h); + else if (memcmp (hdr, "EOH", 4) == 0) + return 0; + else + { + fprintf (stderr, "ghw_read_base: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + { + fprintf (stderr, "ghw_read_base: error in section %s\n", hdr); + return res; + } + } +} + +int +ghw_read_signal_value (struct ghw_handler *h, struct ghw_sig *s) +{ + return ghw_read_value (h, s->val, s->type); +} + +int +ghw_read_snapshot (struct ghw_handler *h) +{ + unsigned char hdr[12]; + int i; + struct ghw_sig *s; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + if (hdr[0] != 0 || hdr[1] != 0 || hdr[2] != 0 || hdr[3] != 0) + return -1; + h->snap_time = ghw_get_i64 (h, &hdr[4]); + if (h->flag_verbose > 1) + printf ("Time is %lld fs\n", h->snap_time); + + for (i = 0; i < h->nbr_sigs; i++) + { + s = &h->sigs[i]; + if (s->type != NULL) + { + if (h->flag_verbose > 1) + printf ("read type %d for sig %d\n", s->type->kind, i); + if (ghw_read_signal_value (h, s) < 0) + return -1; + } + } + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + + if (memcmp (hdr, "ESN", 4)) + return -1; + + return 0; +} + +void ghw_disp_values (struct ghw_handler *h); + +int +ghw_read_cycle_start (struct ghw_handler *h) +{ + unsigned char hdr[8]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + h->snap_time = ghw_get_i64 (h, hdr); + return 0; +} + +int +ghw_read_cycle_cont (struct ghw_handler *h, int *list) +{ + int i; + int *list_p; + + i = 0; + list_p = list; + while (1) + { + uint32_t d; + + /* Read delta to next signal. */ + if (ghw_read_uleb128 (h, &d) < 0) + return -1; + if (d == 0) + { + /* Last signal reached. */ + break; + } + + /* Find next signal. */ + while (d > 0) + { + i++; + if (h->sigs[i].type != NULL) + d--; + } + + if (ghw_read_signal_value (h, &h->sigs[i]) < 0) + return -1; + if (list_p) + *list_p++ = i; + } + + if (list_p) + *list_p = 0; + return 0; +} + +int +ghw_read_cycle_next (struct ghw_handler *h) +{ + int64_t d_time; + + if (ghw_read_lsleb128 (h, &d_time) < 0) + return -1; + if (d_time == -1) + return 0; + h->snap_time += d_time; + return 1; +} + + +int +ghw_read_cycle_end (struct ghw_handler *h) +{ + char hdr[4]; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "ECY", 4)) + return -1; + + return 0; +} + +static const char * +ghw_get_lit (union ghw_type *type, int e) +{ + if (e >= type->en.nbr || e < 0) + return "??"; + else + return type->en.lits[e]; +} + +static void +ghw_disp_lit (union ghw_type *type, int e) +{ + printf ("%s (%d)", ghw_get_lit (type, e), e); +} + +void +ghw_disp_value (union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + ghw_disp_lit (type, val->b2); + break; + case ghdl_rtik_type_e8: + ghw_disp_lit (type, val->e8); + break; + case ghdl_rtik_type_i32: + printf ("%d", val->i32); + break; + case ghdl_rtik_type_p64: + printf ("%lld", val->i64); + break; + case ghdl_rtik_type_f64: + printf ("%g", val->f64); + break; + default: + fprintf (stderr, "ghw_disp_value: cannot handle type %d\n", + type->kind); + abort (); + } +} + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. +*/ +void +ghw_get_value (char *buf, int len, union ghw_val *val, union ghw_type *type) +{ + switch (ghw_get_base_type (type)->kind) + { + case ghdl_rtik_type_b2: + if (val->b2 <= 1) + { + strncpy (buf, type->en.lits[val->b2], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->b2); + } + break; + case ghdl_rtik_type_e8: + if (val->b2 <= type->en.nbr) + { + strncpy (buf, type->en.lits[val->e8], len - 1); + buf[len - 1] = 0; + } + else + { + snprintf (buf, len, "?%d", val->e8); + } + break; + case ghdl_rtik_type_i32: + snprintf (buf, len, "%d", val->i32); + break; + case ghdl_rtik_type_p64: + snprintf (buf, len, "%lld", val->i64); + break; + case ghdl_rtik_type_f64: + snprintf (buf, len, "%g", val->f64); + break; + default: + snprintf (buf, len, "?bad type %d?", type->kind); + } +} + +void +ghw_disp_values (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_sigs; i++) + { + struct ghw_sig *s = &h->sigs[i]; + if (s->type != NULL) + { + printf ("#%d: ", i); + ghw_disp_value (s->val, s->type); + printf ("\n"); + } + } +} + +int +ghw_read_directory (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int nbr_entries; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + nbr_entries = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Directory (%d entries):\n", nbr_entries); + + for (i = 0; i < nbr_entries; i++) + { + unsigned char ent[8]; + int pos; + + if (fread (ent, sizeof (ent), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &ent[4]); + if (h->flag_verbose) + printf (" %s at %d\n", ent, pos); + } + + if (fread (hdr, 4, 1, h->stream) != 1) + return -1; + if (memcmp (hdr, "EOD", 4)) + return -1; + return 0; +} + +int +ghw_read_tailer (struct ghw_handler *h) +{ + unsigned char hdr[8]; + int pos; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + return -1; + + pos = ghw_get_i32 (h, &hdr[4]); + + if (h->flag_verbose) + printf ("Tailer: directory at %d\n", pos); + return 0; +} + +enum ghw_res +ghw_read_sm_hdr (struct ghw_handler *h, int *list) +{ + unsigned char hdr[4]; + int res; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return ghw_res_eof; + else + return ghw_res_error; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (res < 0) + return res; + return ghw_res_snapshot; + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + res = ghw_read_cycle_cont (h, list); + if (res < 0) + return res; + + return ghw_res_cycle; + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + return ghw_res_other; +} + +int +ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm) +{ + int res; + + while (1) + { + /* printf ("sm: state = %d\n", *sm); */ + switch (*sm) + { + case ghw_sm_init: + case ghw_sm_sect: + res = ghw_read_sm_hdr (h, NULL); + switch (res) + { + case ghw_res_other: + break; + case ghw_res_snapshot: + *sm = ghw_sm_sect; + return res; + case ghw_res_cycle: + *sm = ghw_sm_cycle; + return res; + default: + return res; + } + break; + case ghw_sm_cycle: + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + return ghw_res_cycle; + } + res = ghw_read_cycle_end (h); + if (res < 0) + return res; + *sm = ghw_sm_sect; + break; + } + } +} + +int +ghw_read_cycle (struct ghw_handler *h) +{ + int res; + + res = ghw_read_cycle_start (h); + if (res < 0) + return res; + while (1) + { + res = ghw_read_cycle_cont (h, NULL); + if (res < 0) + return res; + + if (0) + printf ("Time is %lld fs\n", h->snap_time); + if (0) + ghw_disp_values (h); + + + res = ghw_read_cycle_next (h); + if (res < 0) + return res; + if (res == 0) + break; + } + res = ghw_read_cycle_end (h); + return res; +} + +int +ghw_read_dump (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int res; + + while (1) + { + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return 0; + else + return -1; + } + if (memcmp (hdr, "SNP", 4) == 0) + { + res = ghw_read_snapshot (h); + if (0 && res >= 0) + ghw_disp_values (h); + } + else if (memcmp (hdr, "CYC", 4) == 0) + { + res = ghw_read_cycle (h); + } + else if (memcmp (hdr, "DIR", 4) == 0) + { + res = ghw_read_directory (h); + } + else if (memcmp (hdr, "TAI", 4) == 0) + { + res = ghw_read_tailer (h); + } + else + { + fprintf (stderr, "unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return -1; + } + if (res != 0) + return res; + } +} + +struct ghw_section ghw_sections[] = { + { "\0\0\0", NULL }, + { "STR", ghw_read_str }, + { "HIE", ghw_read_hie }, + { "TYP", ghw_read_type }, + { "WKT", ghw_read_wk_types }, + { "EOH", ghw_read_eoh }, + { "SNP", ghw_read_snapshot }, + { "CYC", ghw_read_cycle }, + { "DIR", ghw_read_directory }, + { "TAI", ghw_read_tailer } +}; + +int +ghw_read_section (struct ghw_handler *h) +{ + unsigned char hdr[4]; + int i; + + if (fread (hdr, sizeof (hdr), 1, h->stream) != 1) + { + if (feof (h->stream)) + return -2; + else + return -1; + } + + for (i = 1; i < sizeof (ghw_sections) / sizeof (*ghw_sections); i++) + if (memcmp (hdr, ghw_sections[i].name, 4) == 0) + return i; + + fprintf (stderr, "ghw_read_section: unknown GHW section %c%c%c%c\n", + hdr[0], hdr[1], hdr[2], hdr[3]); + return 0; +} + +void +ghw_close (struct ghw_handler *h) +{ + if (h->stream) + { + fclose (h->stream); + h->stream = NULL; + } +} + +const char * +ghw_get_dir (int is_downto) +{ + return is_downto ? "downto" : "to"; +} + +void +ghw_disp_range (union ghw_type *type, union ghw_range *rng) +{ + switch (rng->kind) + { + case ghdl_rtik_type_e8: + printf ("%s %s %s", ghw_get_lit (type, rng->e8.left), + ghw_get_dir (rng->e8.dir), ghw_get_lit (type, rng->e8.right)); + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_p32: + printf ("%d %s %d", + rng->i32.left, ghw_get_dir (rng->i32.dir), rng->i32.right); + break; + case ghdl_rtik_type_i64: + case ghdl_rtik_type_p64: + printf ("%lld %s %lld", + rng->i64.left, ghw_get_dir (rng->i64.dir), rng->i64.right); + break; + case ghdl_rtik_type_f64: + printf ("%g %s %g", + rng->f64.left, ghw_get_dir (rng->f64.dir), rng->f64.right); + break; + default: + printf ("?(%d)", rng->kind); + } +} + +void +ghw_disp_type (struct ghw_handler *h, union ghw_type *t) +{ + switch (t->kind) + { + case ghdl_rtik_type_b2: + case ghdl_rtik_type_e8: + { + struct ghw_type_enum *e = &t->en; + int i; + + printf ("type %s is (", e->name); + for (i = 0; i < e->nbr; i++) + { + if (i != 0) + printf (", "); + printf ("%s", e->lits[i]); + } + printf (");"); + if (e->wkt != ghw_wkt_unknown) + printf (" -- WKT:%d", e->wkt); + printf ("\n"); + } + break; + case ghdl_rtik_type_i32: + case ghdl_rtik_type_f64: + { + struct ghw_type_scalar *s = &t->sc; + printf ("type %s is range <>;\n", s->name); + } + break; + case ghdl_rtik_type_p32: + case ghdl_rtik_type_p64: + { + int i; + + struct ghw_type_physical *p = &t->ph; + printf ("type %s is range <> units\n", p->name); + for (i = 0; i < p->nbr_units; i++) + { + struct ghw_unit *u = &p->units[i]; + printf (" %s = %lld %s;\n", u->name, u->val, p->units[0].name); + } + printf ("end units\n"); + } + break; + case ghdl_rtik_subtype_scalar: + { + struct ghw_subtype_scalar *s = &t->ss; + printf ("subtype %s is ", s->name); + ghw_disp_typename (h, s->base); + printf (" range "); + ghw_disp_range (s->base, s->rng); + printf (";\n"); + } + break; + case ghdl_rtik_type_array: + { + struct ghw_type_array *a = &t->ar; + int i; + + printf ("type %s is array (", a->name); + for (i = 0; i < a->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_typename (h, a->dims[i]); + printf (" range <>"); + } + printf (") of "); + ghw_disp_typename (h, a->el); + printf (";\n"); + } + break; + case ghdl_rtik_subtype_array: + case ghdl_rtik_subtype_array_ptr: + { + struct ghw_subtype_array *a = &t->sa; + int i; + + printf ("subtype %s is ", a->name); + ghw_disp_typename (h, (union ghw_type *)a->base); + printf (" ("); + for (i = 0; i < a->base->nbr_dim; i++) + { + if (i != 0) + printf (", "); + ghw_disp_range ((union ghw_type *)a->base, a->rngs[i]); + } + printf (");\n"); + } + break; + case ghdl_rtik_type_record: + { + struct ghw_type_record *r = &t->rec; + int i; + + printf ("type %s is record\n", r->name); + for (i = 0; i < r->nbr_fields; i++) + { + printf (" %s: ", r->el[i].name); + ghw_disp_typename (h, r->el[i].type); + printf ("\n"); + } + printf ("end record;\n"); + } + break; + default: + printf ("ghw_disp_type: unhandled type kind %d\n", t->kind); + } +} + +void +ghw_disp_types (struct ghw_handler *h) +{ + int i; + + for (i = 0; i < h->nbr_types; i++) + ghw_disp_type (h, h->types[i]); +} diff --git a/src/translate/grt/ghwlib.h b/src/translate/grt/ghwlib.h new file mode 100644 index 0000000..0138267 --- /dev/null +++ b/src/translate/grt/ghwlib.h @@ -0,0 +1,399 @@ +/* GHDL Wavefile reader library. + Copyright (C) 2005 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. +*/ + + +#ifndef _GHWLIB_H_ +#define _GHWLIB_H_ + +#include <stdio.h> +#include <stdlib.h> + +#ifdef __GNUC__ +#include <stdint.h> +#endif + +enum ghdl_rtik { + ghdl_rtik_top, /* 0 */ + ghdl_rtik_library, + ghdl_rtik_package, + ghdl_rtik_package_body, + ghdl_rtik_entity, + ghdl_rtik_architecture, /* 5 */ + ghdl_rtik_process, + ghdl_rtik_block, + ghdl_rtik_if_generate, + ghdl_rtik_for_generate, + ghdl_rtik_instance, + ghdl_rtik_constant, + ghdl_rtik_iterator, + ghdl_rtik_variable, + ghdl_rtik_signal, + ghdl_rtik_file, + ghdl_rtik_port, + ghdl_rtik_generic, + ghdl_rtik_alias, + ghdl_rtik_guard, + ghdl_rtik_component, + ghdl_rtik_attribute, + ghdl_rtik_type_b2, /* 22 */ + ghdl_rtik_type_e8, + ghdl_rtik_type_e32, + ghdl_rtik_type_i32, /* 25 */ + ghdl_rtik_type_i64, + ghdl_rtik_type_f64, + ghdl_rtik_type_p32, + ghdl_rtik_type_p64, + ghdl_rtik_type_access, /* 30 */ + ghdl_rtik_type_array, + ghdl_rtik_type_record, + ghdl_rtik_type_file, + ghdl_rtik_subtype_scalar, + ghdl_rtik_subtype_array, /* 35 */ + ghdl_rtik_subtype_array_ptr, + ghdl_rtik_subtype_unconstrained_array, + ghdl_rtik_subtype_record, + ghdl_rtik_subtype_access, + ghdl_rtik_type_protected, + ghdl_rtik_element, + ghdl_rtik_unit, + ghdl_rtik_attribute_transaction, + ghdl_rtik_attribute_quiet, + ghdl_rtik_attribute_stable, + ghdl_rtik_error +}; + +/* Well-known types. */ +enum ghw_wkt_type { + ghw_wkt_unknown, + ghw_wkt_boolean, + ghw_wkt_bit, + ghw_wkt_std_ulogic +}; + +struct ghw_range_b2 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_e8 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + unsigned char left; + unsigned char right; +}; + +struct ghw_range_i32 +{ + enum ghdl_rtik kind : 8; + int dir : 8; /* 0: to, !0: downto. */ + int32_t left; + int32_t right; +}; + +struct ghw_range_i64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + int64_t left; + int64_t right; +}; + +struct ghw_range_f64 +{ + enum ghdl_rtik kind : 8; + int dir : 8; + double left; + double right; +}; + +union ghw_range +{ + enum ghdl_rtik kind : 8; + struct ghw_range_e8 e8; + struct ghw_range_i32 i32; + struct ghw_range_i64 i64; + struct ghw_range_f64 f64; +}; + +/* Note: the first two fields must be kind and name. */ +union ghw_type; + +struct ghw_type_common +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_type_enum +{ + enum ghdl_rtik kind; + const char *name; + + enum ghw_wkt_type wkt; + unsigned int nbr; + const char **lits; +}; + +struct ghw_type_scalar +{ + enum ghdl_rtik kind; + const char *name; +}; + +struct ghw_unit +{ + const char *name; + int64_t val; +}; + +struct ghw_type_physical +{ + enum ghdl_rtik kind; + const char *name; + uint32_t nbr_units; + struct ghw_unit *units; +}; + +struct ghw_type_array +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_dim; + union ghw_type *el; + union ghw_type **dims; +}; + +struct ghw_subtype_array +{ + enum ghdl_rtik kind; + const char *name; + + struct ghw_type_array *base; + int nbr_el; + union ghw_range **rngs; +}; + +struct ghw_subtype_scalar +{ + enum ghdl_rtik kind; + const char *name; + + union ghw_type *base; + union ghw_range *rng; +}; + +struct ghw_record_element +{ + const char *name; + union ghw_type *type; +}; + +struct ghw_type_record +{ + enum ghdl_rtik kind; + const char *name; + + unsigned int nbr_fields; + int nbr_el; /* Number of scalar signals. */ + struct ghw_record_element *el; +}; + +union ghw_type +{ + enum ghdl_rtik kind; + struct ghw_type_common common; + struct ghw_type_enum en; + struct ghw_type_scalar sc; + struct ghw_type_physical ph; + struct ghw_subtype_scalar ss; + struct ghw_subtype_array sa; + struct ghw_type_array ar; + struct ghw_type_record rec; +}; + +union ghw_val +{ + unsigned char b2; + unsigned char e8; + int32_t i32; + int64_t i64; + double f64; +}; + +/* A non-composite signal. */ +struct ghw_sig +{ + union ghw_type *type; + union ghw_val *val; +}; + +enum ghw_hie_kind { + ghw_hie_eoh = 0, + ghw_hie_design = 1, + ghw_hie_block = 3, + ghw_hie_generate_if = 4, + ghw_hie_generate_for = 5, + ghw_hie_instance = 6, + ghw_hie_package = 7, + ghw_hie_process = 13, + ghw_hie_generic = 14, + ghw_hie_eos = 15, + ghw_hie_signal = 16, + ghw_hie_port_in = 17, + ghw_hie_port_out = 18, + ghw_hie_port_inout = 19, + ghw_hie_port_buffer = 20, + ghw_hie_port_linkage = 21 +}; + +struct ghw_hie +{ + enum ghw_hie_kind kind; + struct ghw_hie *parent; + const char *name; + struct ghw_hie *brother; + union + { + struct + { + struct ghw_hie *child; + union ghw_type *iter_type; + union ghw_val *iter_value; + } blk; + struct + { + union ghw_type *type; + /* Array of signal elements. + Last element is 0. */ + unsigned int *sigs; + } sig; + } u; +}; + +struct ghw_handler +{ + FILE *stream; + /* True if words are big-endian. */ + int word_be; + int word_len; + int off_len; + /* Minor version. */ + int version; + + /* Set by user. */ + int flag_verbose; + + /* String table. */ + /* Number of strings. */ + int nbr_str; + /* Size of the strings (without nul). */ + int str_size; + /* String table. */ + char **str_table; + /* Array containing strings. */ + char *str_content; + + /* Type table. */ + int nbr_types; + union ghw_type **types; + + /* Non-composite (or basic) signals. */ + int nbr_sigs; + struct ghw_sig *sigs; + + /* Hierarchy. */ + struct ghw_hie *hie; + + /* Time of the next cycle. */ + int64_t snap_time; +}; + +/* Open a GHW file with H. + Return < 0 in case of error. */ +int ghw_open (struct ghw_handler *h, const char *filename); + +union ghw_type *ghw_get_base_type (union ghw_type *t); + +/* Put the ASCII representation of VAL into BUF, whose size if LEN. + A NUL is always written to BUF. */ +void ghw_get_value (char *buf, int len, + union ghw_val *val, union ghw_type *type); + +const char *ghw_get_hie_name (struct ghw_hie *h); + +void ghw_disp_hie (struct ghw_handler *h, struct ghw_hie *top); + +int ghw_read_base (struct ghw_handler *h); + +void ghw_disp_values (struct ghw_handler *h); + +int ghw_read_cycle_start (struct ghw_handler *h); + +int ghw_read_cycle_cont (struct ghw_handler *h, int *list); + +int ghw_read_cycle_next (struct ghw_handler *h); + +int ghw_read_cycle_end (struct ghw_handler *h); + +enum ghw_sm_type { + /* At init; + Read section name. */ + ghw_sm_init = 0, + ghw_sm_sect = 1, + ghw_sm_cycle = 2 +}; + +enum ghw_res { + ghw_res_error = -1, + ghw_res_eof = -2, + ghw_res_ok = 0, + ghw_res_snapshot = 1, + ghw_res_cycle = 2, + ghw_res_other = 3 +}; + +int ghw_read_sm (struct ghw_handler *h, enum ghw_sm_type *sm); + +int ghw_read_dump (struct ghw_handler *h); + +struct ghw_section { + const char name[4]; + int (*handler)(struct ghw_handler *h); +}; + +extern struct ghw_section ghw_sections[]; + +int ghw_read_section (struct ghw_handler *h); + +void ghw_close (struct ghw_handler *h); + +const char *ghw_get_dir (int is_downto); + +/* Note: TYPE must be a base type (used only to display literals). */ +void ghw_disp_range (union ghw_type *type, union ghw_range *rng); + +void ghw_disp_type (struct ghw_handler *h, union ghw_type *t); + +void ghw_disp_types (struct ghw_handler *h); +#endif /* _GHWLIB_H_ */ diff --git a/src/translate/grt/grt-arch.ads b/src/translate/grt/grt-arch.ads new file mode 100644 index 0000000..5f5aa0e --- /dev/null +++ b/src/translate/grt/grt-arch.ads @@ -0,0 +1,2 @@ +With Grt.Arch_None; +Package Grt.Arch renames Grt.Arch_None; diff --git a/src/translate/grt/grt-arch_none.adb b/src/translate/grt/grt-arch_none.adb new file mode 100644 index 0000000..14db1c7 --- /dev/null +++ b/src/translate/grt/grt-arch_none.adb @@ -0,0 +1,7 @@ +package body Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64 is + begin + return 0; + end Get_Time_Stamp; +end Grt.Arch_None; + diff --git a/src/translate/grt/grt-arch_none.ads b/src/translate/grt/grt-arch_none.ads new file mode 100644 index 0000000..f8ae437 --- /dev/null +++ b/src/translate/grt/grt-arch_none.ads @@ -0,0 +1,6 @@ +with Grt.Types; use Grt.Types; + +package Grt.Arch_None is + function Get_Time_Stamp return Ghdl_U64; + pragma Inline (Get_Time_Stamp); +end Grt.Arch_None; diff --git a/src/translate/grt/grt-astdio.adb b/src/translate/grt/grt-astdio.adb new file mode 100644 index 0000000..456d024 --- /dev/null +++ b/src/translate/grt/grt-astdio.adb @@ -0,0 +1,231 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- 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.C; use Grt.C; + +package body Grt.Astdio is + procedure Put (Stream : FILEs; Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, Stream); + end Put; + + procedure Put (Stream : FILEs; C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end Put; + + procedure Put (Stream : FILEs; Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, Stream); + end Put; + + procedure New_Line (Stream : FILEs) is + begin + Put (Stream, Nl); + end New_Line; + + procedure Put (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stdout); + end Put; + + procedure Put (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stdout); + end Put; + + procedure Put (Str : Ghdl_C_String) + is + Len : Natural; + S : size_t; + pragma Unreferenced (S); + begin + Len := strlen (Str); + S := fwrite (Str (1)'Address, size_t (Len), 1, stdout); + end Put; + + procedure New_Line is + begin + Put (Nl); + end New_Line; + + procedure Put_Line (Str : String) + is + begin + Put (Str); + New_Line; + end Put_Line; + + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type) + is + S : String (1 .. 3); + begin + if Str.Str = null then + S (1) := '''; + S (2) := Character'Val (Str.Len); + S (3) := '''; + Put (Stream, S); + else + Put (Stream, Str.Str (1 .. Str.Len)); + end if; + end Put_Str_Len; + + generic + type Ntype is range <>; + Max_Len : Natural; + procedure Put_Ntype (Stream : FILEs; N : Ntype); + + procedure Put_Ntype (Stream : FILEs; N : Ntype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Ntype; + begin + -- V is negativ. + if N > 0 then + V := -N; + else + V := N; + end if; + loop + Str (P) := Character'Val (48 - (V rem 10)); -- V is <= 0. + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + Str (P) := '-'; + end if; + Put (Stream, Str (P .. Max_Len)); + end Put_Ntype; + + generic + type Utype is mod <>; + Max_Len : Natural; + procedure Put_Utype (Stream : FILEs; N : Utype); + + procedure Put_Utype (Stream : FILEs; N : Utype) + is + Str : String (1 .. Max_Len); + P : Natural := Str'Last; + V : Utype := N; + begin + loop + Str (P) := Character'Val (48 + (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + Put (Stream, Str (P .. Max_Len)); + end Put_Utype; + + procedure Put_I32_1 is new Put_Ntype (Ntype => Ghdl_I32, Max_Len => 11); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32) renames Put_I32_1; + + procedure Put_U32_1 is new Put_Utype (Utype => Ghdl_U32, Max_Len => 11); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32) renames Put_U32_1; + + procedure Put_I64_1 is new Put_Ntype (Ntype => Ghdl_I64, Max_Len => 20); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64) renames Put_I64_1; + + procedure Put_U64_1 is new Put_Utype (Utype => Ghdl_U64, Max_Len => 20); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64) renames Put_U64_1; + + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64) + is + procedure Fprintf_G (Stream : FILEs; + Arg : Ghdl_F64); + pragma Import (C, Fprintf_G, "__ghdl_fprintf_g"); + begin + Fprintf_G (Stream, F64); + end Put_F64; + + Hex_Map : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Put (Stream : FILEs; Addr : System.Address) + is + Res : String (1 .. System.Word_Size / 4); + Val : Integer_Address := To_Integer (Addr); + begin + for I in reverse Res'Range loop + Res (I) := Hex_Map (Natural (Val and 15)); + Val := Val / 16; + end loop; + Put (Stream, Res); + end Put; + + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type) is + begin + case Dir is + when Dir_To => + Put (Stream, " to "); + when Dir_Downto => + Put (Stream, " downto "); + end case; + end Put_Dir; + + procedure Put_Time (Stream : FILEs; Time : Std_Time) is + begin + if Time = Std_Time'First then + Put (Stream, "-Inf"); + else + -- Do not bother with sec, min, and hr. + if (Time mod 1_000_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000_000)); + Put (Stream, "ms"); + elsif (Time mod 1_000_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000_000)); + Put (Stream, "us"); + elsif (Time mod 1_000_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000_000)); + Put (Stream, "ns"); + elsif (Time mod 1_000) = 0 then + Put_I64 (Stream, Ghdl_I64 (Time / 1_000)); + Put (Stream, "ps"); + else + Put_I64 (Stream, Ghdl_I64 (Time)); + Put (Stream, "fs"); + end if; + end if; + end Put_Time; + +end Grt.Astdio; diff --git a/src/translate/grt/grt-astdio.ads b/src/translate/grt/grt-astdio.ads new file mode 100644 index 0000000..8e8b739 --- /dev/null +++ b/src/translate/grt/grt-astdio.ads @@ -0,0 +1,60 @@ +-- GHDL Run Time (GRT) stdio subprograms for GRT types. +-- 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; +with Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Astdio is + pragma Preelaborate (Grt.Astdio); + + -- Procedures to disp on STREAM. + procedure Put (Stream : FILEs; Str : String); + procedure Put_I32 (Stream : FILEs; I32 : Ghdl_I32); + procedure Put_U32 (Stream : FILEs; U32 : Ghdl_U32); + procedure Put_I64 (Stream : FILEs; I64 : Ghdl_I64); + procedure Put_U64 (Stream : FILEs; U64 : Ghdl_U64); + procedure Put_F64 (Stream : FILEs; F64 : Ghdl_F64); + procedure Put (Stream : FILEs; Addr : System.Address); + procedure Put (Stream : FILEs; Str : Ghdl_C_String); + procedure Put (Stream : FILEs; C : Character); + procedure New_Line (Stream : FILEs); + + -- Display time with unit, without space. + -- Eg: 10ns, 100ms, 97ps... + procedure Put_Time (Stream : FILEs; Time : Std_Time); + + -- And on stdout. + procedure Put (Str : String); + procedure Put (C : Character); + procedure New_Line; + procedure Put_Line (Str : String); + procedure Put (Str : Ghdl_C_String); + + -- Put STR using put procedures. + procedure Put_Str_Len (Stream : FILEs; Str : Ghdl_Str_Len_Type); + + -- Put " to " or " downto ". + procedure Put_Dir (Stream : FILEs; Dir : Ghdl_Dir_Type); +end Grt.Astdio; diff --git a/src/translate/grt/grt-avhpi.adb b/src/translate/grt/grt-avhpi.adb new file mode 100644 index 0000000..b935fd9 --- /dev/null +++ b/src/translate/grt/grt-avhpi.adb @@ -0,0 +1,1142 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- 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; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Avhpi is + procedure Get_Root_Inst (Res : out VhpiHandleT) + is + begin + Res := (Kind => VhpiRootInstK, + Ctxt => Get_Top_Context); + end Get_Root_Inst; + + procedure Get_Package_Inst (Res : out VhpiHandleT) is + begin + Res := (Kind => VhpiIteratorK, + Ctxt => (Base => Null_Address, + Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)), + Rel => VhpiPackInsts, + It_Cur => 0, + It2 => 0, + Max2 => 0); + end Get_Package_Inst; + + -- Number of elements in an array. + function Ranges_To_Length (Rngs : Ghdl_Range_Array; + Indexes : Ghdl_Rti_Arr_Acc) + return Ghdl_Index_Type + is + Res : Ghdl_Index_Type; + begin + Res := 1; + for I in Rngs'Range loop + Res := Res * Range_To_Length + (Rngs (I), Get_Base_Type (Indexes (I - Rngs'First))); + end loop; + return Res; + end Ranges_To_Length; + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default value in case of success. + Res := (Kind => VhpiIteratorK, + Ctxt => Ref.Ctxt, + Rel => Rel, + It_Cur => 0, + It2 => 0, + Max2 => 0); + Error := AvhpiErrorOk; + + case Rel is + when VhpiInternalRegions => + case Ref.Kind is + when VhpiRootInstK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK => + return; + when VhpiForGenerateK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + return; + when others => + null; + end case; + when VhpiDecls => + case Ref.Kind is + when VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return; + when VhpiRootInstK + | VhpiPackInstK => + Res.It2 := 1; + return; + when VhpiCompInstStmtK => + Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); + Res.It2 := 1; + return; + when others => + null; + end case; + when VhpiIndexedNames => + case Ref.Kind is + when VhpiGenericDeclK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => Ref.Obj.Obj_Type, + N_Idx => 0, + N_Obj => Ref.Obj); + when VhpiIndexedNameK => + Res := (Kind => AvhpiNameIteratorK, + Ctxt => Ref.Ctxt, + N_Addr => Ref.N_Addr, + N_Type => Ref.N_Type, + N_Idx => 0, + N_Obj => Ref.N_Obj); + when others => + Error := AvhpiErrorNotImplemented; + return; + end case; + case Res.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Res.N_Type); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Res.Ctxt), + Bt, Rngs); + Res.N_Idx := Ranges_To_Length (Rngs, Bt.Indexes); + end; + when others => + Error := AvhpiErrorBadRel; + end case; + return; + when others => + null; + end case; + -- Failure. + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end Vhpi_Iterator; + + -- OBJ_RTI is the RTI for the base name. + function Add_Index (Ctxt : Rti_Context; + Obj_Base : Address; + Obj_Rti : Ghdl_Rtin_Object_Acc; + El_Type : Ghdl_Rti_Access; + Off : Ghdl_Index_Type) return Address + is + pragma Unreferenced (Ctxt); + Is_Sig : Boolean; + El_Size : Ghdl_Index_Type; + El_Type1 : Ghdl_Rti_Access; + begin + case Obj_Rti.Common.Kind is + when Ghdl_Rtik_Generic => + Is_Sig := False; + when others => + Internal_Error ("add_index"); + end case; + + if El_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + El_Type1 := Get_Base_Type (El_Type); + else + El_Type1 := El_Type; + end if; + + case El_Type1.Kind is + when Ghdl_Rtik_Type_P64 => + if Is_Sig then + El_Size := Address'Size / Storage_Unit; + else + El_Size := Ghdl_I64'Size / Storage_Unit; + end if; + when Ghdl_Rtik_Subtype_Array => + if Is_Sig then + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Sigsize); + else + El_Size := Ghdl_Index_Type + (To_Ghdl_Rtin_Subtype_Array_Acc (El_Type1).Valsize); + end if; + when others => + Internal_Error ("add_index"); + end case; + return Obj_Base + Off * El_Size; + end Add_Index; + + procedure Vhpi_Scan_Indexed_Name (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + El_Type : Ghdl_Rti_Access; + begin + if Iterator.N_Idx = 0 then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + El_Type := To_Ghdl_Rtin_Type_Array_Acc + (Get_Base_Type (Iterator.N_Type)).Element; + + Res := (Kind => VhpiIndexedNameK, + Ctxt => Iterator.Ctxt, + N_Addr => Iterator.N_Addr, + N_Type => El_Type, + N_Idx => 0, + N_Obj => Iterator.N_Obj); + + -- Increment Address. + Iterator.N_Addr := Add_Index + (Iterator.Ctxt, Iterator.N_Addr, Iterator.N_Obj, El_Type, 1); + + Iterator.N_Idx := Iterator.N_Idx - 1; + Error := AvhpiErrorOk; + end Vhpi_Scan_Indexed_Name; + + procedure Vhpi_Scan_Internal_Regions (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + Nblk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + loop + << Again >> null; + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + Ch := Blk.Children (Iterator.It_Cur); + Nblk := To_Ghdl_Rtin_Block_Acc (Ch); + + if Iterator.Max2 /= 0 then + -- A for generate. + Iterator.It2 := Iterator.It2 + 1; + if Iterator.It2 >= Iterator.Max2 then + -- End of loop. + Iterator.Max2 := 0; + Iterator.It_Cur := Iterator.It_Cur + 1; + goto Again; + else + declare + Base : Address; + begin + Base := To_Addr_Acc (Iterator.Ctxt.Base + Nblk.Loc).all; + Base := Base + Iterator.It2 * Nblk.Size; + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => Base, + Block => Ch)); + + Error := AvhpiErrorOk; + return; + end; + end if; + end if; + + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Process => + Res := (Kind => VhpiProcessStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_Block => + Res := (Kind => VhpiBlockStmtK, + Ctxt => (Base => Iterator.Ctxt.Base + Nblk.Loc, + Block => Ch)); + Error := AvhpiErrorOk; + return; + when Ghdl_Rtik_If_Generate => + Res := (Kind => VhpiIfGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + -- Return only if the condition is true. + if Res.Ctxt.Base /= Null_Address then + Error := AvhpiErrorOk; + return; + end if; + when Ghdl_Rtik_For_Generate => + Res := (Kind => VhpiForGenerateK, + Ctxt => (Base => To_Addr_Acc (Iterator.Ctxt.Base + + Nblk.Loc).all, + Block => Ch)); + Iterator.Max2 := Get_For_Generate_Length (Nblk, Iterator.Ctxt); + Iterator.It2 := 0; + if Iterator.Max2 > 0 then + Iterator.It_Cur := Iterator.It_Cur - 1; + Error := AvhpiErrorOk; + return; + end if; + -- If the iterator range is nul, then continue to scan. + when Ghdl_Rtik_Instance => + Res := (Kind => VhpiCompInstStmtK, + Ctxt => Iterator.Ctxt, + Inst => To_Ghdl_Rtin_Instance_Acc (Ch)); + Error := AvhpiErrorOk; + return; + when others => + -- Next one. + null; + end case; + end loop; + end Vhpi_Scan_Internal_Regions; + + procedure Rti_To_Handle (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Res : out VhpiHandleT) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Signal => + Res := (Kind => VhpiSigDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Port => + Res := (Kind => VhpiPortDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Generic => + Res := (Kind => VhpiGenericDeclK, + Ctxt => Ctxt, + Obj => To_Ghdl_Rtin_Object_Acc (Rti)); + when Ghdl_Rtik_Subtype_Array => + declare + Atype : Ghdl_Rtin_Subtype_Array_Acc; + Bt : Ghdl_Rtin_Type_Array_Acc; + begin + Atype := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt := Atype.Basetype; + if Atype.Name = Bt.Name then + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + else + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + end if; + end; + when Ghdl_Rtik_Type_Array => + Res := (Kind => VhpiArrayTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + Res := (Kind => VhpiPhysTypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when Ghdl_Rtik_Subtype_Scalar => + Res := (Kind => VhpiSubtypeDeclK, + Ctxt => Ctxt, + Atype => Rti); + when others => + Res := (Kind => VhpiUndefined, + Ctxt => Ctxt); + end case; + end Rti_To_Handle; + + procedure Vhpi_Scan_Decls (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + Blk : Ghdl_Rtin_Block_Acc; + Ch : Ghdl_Rti_Access; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + + -- If there is no context, returns now. + -- This may happen for a unbound compinststmt. + if Blk = null then + Error := AvhpiErrorIteratorEnd; + return; + end if; + + if Iterator.It2 = 1 then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Iterate on the entity. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package_Body => + -- Iterate on the package. + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + when Ghdl_Rtik_Package => + -- Only for std.standard. + Iterator.It2 := 0; + when others => + Internal_Error ("vhpi_scan_decls"); + end case; + end if; + loop + loop + exit when Iterator.It_Cur >= Blk.Nbr_Child; + + Ch := Blk.Children (Iterator.It_Cur); + + Iterator.It_Cur := Iterator.It_Cur + 1; + + case Ch.Kind is + when Ghdl_Rtik_Port + | Ghdl_Rtik_Generic + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Type_Array + | Ghdl_Rtik_Subtype_Array + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle (Ch, Iterator.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + return; + else + Internal_Error ("vhpi_scan_decls"); + end if; + when others => + null; + end case; + end loop; + case Iterator.It2 is + when 1 => + -- Iterate on the architecture/package decl. + Iterator.It2 := 0; + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + Iterator.It_Cur := 0; + when others => + exit; + end case; + end loop; + Error := AvhpiErrorIteratorEnd; + end Vhpi_Scan_Decls; + + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + if Iterator.Kind = AvhpiNameIteratorK then + case Iterator.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + Vhpi_Scan_Indexed_Name (Iterator, Res, Error); + when others => + Error := AvhpiErrorHandle; + Res := Null_Handle; + end case; + return; + elsif Iterator.Kind /= VhpiIteratorK then + Error := AvhpiErrorHandle; + Res := Null_Handle; + return; + end if; + + case Iterator.Rel is + when VhpiPackInsts => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; + return; + end if; + Res := (Kind => VhpiPackInstK, + Ctxt => (Base => Null_Address, + Block => Blk.Children (Iterator.It_Cur))); + Iterator.It_Cur := Iterator.It_Cur + 1; + Error := AvhpiErrorOk; + end; + when VhpiInternalRegions => + Vhpi_Scan_Internal_Regions (Iterator, Res, Error); + when VhpiDecls => + Vhpi_Scan_Decls (Iterator, Res, Error); + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Scan; + + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String + is + begin + case Obj.Kind is + when VhpiEnumTypeDeclK => + return To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name; + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK => + return To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name; + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + return Blk.Name; + end; + when VhpiCompInstStmtK => + return Obj.Inst.Name; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + return Obj.Obj.Name; + when VhpiSubtypeDeclK => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name; + when others => + return null; + end case; + end Avhpi_Get_Base_Name; + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural) + is + subtype R_Type is String (1 .. Res'Length); + R : R_Type renames Res; + + procedure Add (C : Character) is + begin + Len := Len + 1; + if Len <= R_Type'Last then + R (Len) := C; + end if; + end Add; + + procedure Add (Str : String) is + begin + for I in Str'Range loop + Add (Str (I)); + end loop; + end Add; + + procedure Add (Str : Ghdl_C_String) is + begin + for I in Str'Range loop + exit when Str (I) = NUL; + Add (Str (I)); + end loop; + end Add; + begin + Len := 0; + + case Property is + when VhpiNameP => + case Obj.Kind is + when VhpiEnumTypeDeclK => + Add (To_Ghdl_Rtin_Type_Enum_Acc (Obj.Atype).Name); + when VhpiSubtypeDeclK => + Add (To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj.Atype).Name); + when VhpiArrayTypeDeclK => + Add (To_Ghdl_Rtin_Type_Array_Acc (Obj.Atype).Name); + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK + | VhpiProcessStmtK + | VhpiBlockStmtK + | VhpiIfGenerateK => + Add (To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block).Name); + when VhpiRootInstK => + declare + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + Add (Blk.Name); + end; + when VhpiCompInstStmtK => + Add (Obj.Inst.Name); + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK => + Add (Obj.Obj.Name); + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + Iter_Type : Ghdl_Rti_Access; + Vptr : Ghdl_Value_Ptr; + Buf : String (1 .. 12); + Buf_Len : Natural; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Vptr := To_Ghdl_Value_Ptr + (Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Obj.Ctxt)); + Add (Blk.Name); + Add ('('); + Iter_Type := Iter.Obj_Type; + if Iter_Type.Kind = Ghdl_Rtik_Subtype_Scalar then + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (Iter_Type).Basetype; + end if; + case Iter_Type.Kind is + when Ghdl_Rtik_Type_I32 => + To_String (Buf, Buf_Len, Vptr.I32); + Add (Buf (Buf_Len .. Buf'Last)); +-- when Ghdl_Rtik_Type_E8 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); +-- when Ghdl_Rtik_Type_E32 => +-- Disp_Enum_Value +-- (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); +-- when Ghdl_Rtik_Type_B1 => +-- Disp_Enum_Value +-- (Stream, Rti, +-- Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + when others => + Add ('?'); + end case; + --Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Add (')'); + end; + when others => + null; + end case; + when VhpiCompNameP => + case Obj.Kind is + when VhpiCompInstStmtK => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Obj.Inst.Instance); + if Comp.Common.Kind = Ghdl_Rtik_Component then + Add (Comp.Name); + end if; + end; + when others => + null; + end case; + when VhpiLibLogicalNameP => + case Obj.Kind is + when VhpiPackInstK + | VhpiArchBodyK + | VhpiEntityDeclK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + if Blk.Common.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + if Lib.Common.Kind /= Ghdl_Rtik_Library then + Internal_Error ("VhpiLibLogicalNameP"); + end if; + Add (Lib.Name); + end; + when others => + null; + end case; + when VhpiFullNameP => + declare + Rstr : Rstring; + Nctxt : Rti_Context; + begin + if Obj.Kind = VhpiCompInstStmtK then + Get_Instance_Context (Obj.Inst, Obj.Ctxt, Nctxt); + Get_Path_Name (Rstr, Nctxt, ':', False); + else + Get_Path_Name (Rstr, Obj.Ctxt, ':', False); + end if; + Copy (Rstr, R, Len); + Free (Rstr); + case Obj.Kind is + when VhpiCompInstStmtK => + null; + when VhpiPortDeclK + | VhpiSigDeclK => + Add (':'); + Add (Obj.Obj.Name); + when others => + null; + end case; + end; + when others => + null; + end case; + end Vhpi_Get_Str; + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiDesignUnit => + case Ref.Kind is + when VhpiRootInstK => + case Ref.Ctxt.Block.Kind is + when Ghdl_Rtik_Architecture => + Res := (Kind => VhpiArchBodyK, + Ctxt => Ref.Ctxt); + Error := AvhpiErrorOk; + return; + when others => + return; + end case; + when others => + return; + end case; + when VhpiPrimaryUnit => + case Ref.Kind is + when VhpiArchBodyK => + declare + Rti : Ghdl_Rti_Access; + Ent : Ghdl_Rtin_Block_Acc; + begin + Rti := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block).Parent; + Ent := To_Ghdl_Rtin_Block_Acc (Rti); + Res := (Kind => VhpiEntityDeclK, + Ctxt => (Base => Ref.Ctxt.Base + Ent.Loc, + Block => Rti)); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiIterScheme => + case Ref.Kind is + when VhpiForGenerateK => + declare + Blk : Ghdl_Rtin_Block_Acc; + Iter : Ghdl_Rtin_Object_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ref.Ctxt.Block); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Res := (Kind => VhpiConstDeclK, + Ctxt => Ref.Ctxt, + Obj => Iter); + Error := AvhpiErrorOk; + end; + when others => + return; + end case; + when VhpiSubtype => + case Ref.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Res := (Kind => VhpiSubtypeIndicK, + Ctxt => Ref.Ctxt, + Atype => Ref.Obj.Obj_Type); + Error := AvhpiErrorOk; + when others => + return; + end case; + when VhpiTypeMark => + case Ref.Kind is + when VhpiSubtypeIndicK => + -- FIXME: if the subtype is anonymous, return the base type. + Rti_To_Handle (Ref.Atype, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + return; + when others => + return; + end case; + when VhpiBaseType => + declare + Atype : Ghdl_Rti_Access; + begin + case Ref.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK => + Atype := Ref.Atype; + when VhpiGenericDeclK => + Atype := Ref.Obj.Obj_Type; + when VhpiIndexedNameK => + Atype := Ref.N_Type; + when others => + return; + end case; + case Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Rti_To_Handle + (To_Ghdl_Rti_Access (To_Ghdl_Rtin_Subtype_Array_Acc + (Atype).Basetype), + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Subtype_Scalar => + Rti_To_Handle + (To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype, + Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + when Ghdl_Rtik_Type_Array => + Res := Ref; + Error := AvhpiErrorOk; + when others => + return; + end case; + end; + when VhpiElemSubtype => + declare + Base_Type : Ghdl_Rtin_Type_Array_Acc; + begin + case Ref.Atype.Kind is + when Ghdl_Rtik_Subtype_Array => + Base_Type := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype).Basetype; + when Ghdl_Rtik_Type_Array => + Base_Type := To_Ghdl_Rtin_Type_Array_Acc (Ref.Atype); + when others => + return; + end case; + Rti_To_Handle (Base_Type.Element, Ref.Ctxt, Res); + if Res.Kind /= VhpiUndefined then + Error := AvhpiErrorOk; + end if; + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle; + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + -- Default error. + Error := AvhpiErrorNotImplemented; + + case Rel is + when VhpiConstraints => + case Ref.Kind is + when VhpiSubtypeIndicK => + if Ref.Atype.Kind = Ghdl_Rtik_Subtype_Array then + declare + Arr_Subtype : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Ref.Atype); + Basetype : constant Ghdl_Rtin_Type_Array_Acc := + Arr_Subtype.Basetype; + Idx : constant Ghdl_Index_Type := + Ghdl_Index_Type (Index); + Bounds : Ghdl_Range_Array (0 .. Basetype.Nbr_Dim - 1); + Range_Basetype : Ghdl_Rti_Access; + begin + if Idx not in 1 .. Basetype.Nbr_Dim then + Res := Null_Handle; + Error := AvhpiErrorBadIndex; + return; + end if; + -- constraint type is basetype.indexes (idx - 1) + Bound_To_Range + (Loc_To_Addr (Arr_Subtype.Common.Depth, + Arr_Subtype.Bounds, Ref.Ctxt), + Basetype, Bounds); + Res := (Kind => VhpiIntRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Basetype.Indexes (Idx - 1), + Rng_Addr => Bounds (Idx - 1)); + Range_Basetype := Get_Base_Type (Res.Rng_Type); + case Range_Basetype.Kind is + when Ghdl_Rtik_Type_I32 => + null; + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Res := (Kind => VhpiEnumRangeK, + Ctxt => Ref.Ctxt, + Rng_Type => Res.Rng_Type, + Rng_Addr => Res.Rng_Addr); + when others => + Internal_Error + ("vhpi_handle_by_index/constraint"); + end case; + Error := AvhpiErrorOk; + end; + end if; + when others => + return; + end case; + when VhpiIndexedNames => + declare + Base_Type, El_Type : VhpiHandleT; + begin + Vhpi_Handle (VhpiBaseType, Ref, Base_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + if Vhpi_Get_Kind (Base_Type) /= VhpiArrayTypeDeclK then + Error := AvhpiErrorBadRel; + return; + end if; + Vhpi_Handle (VhpiElemSubtype, Base_Type, El_Type, Error); + if Error /= AvhpiErrorOk then + return; + end if; + Res := (Kind => VhpiIndexedNameK, + Ctxt => Ref.Ctxt, + N_Addr => Avhpi_Get_Address (Ref), + N_Type => El_Type.Atype, + N_Idx => Ghdl_Index_Type (Index), + N_Obj => Ref.Obj); + if Res.N_Addr = Null_Address then + Error := AvhpiErrorBadRel; + return; + end if; + Res.N_Addr := Add_Index + (Res.Ctxt, Res.N_Addr, Res.N_Obj, Res.N_Type, + Ghdl_Index_Type (Index)); + end; + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Handle_By_Index; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiLeftBoundP => + if Obj.Kind /= VhpiIntRangeK then + Res := 0; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Left; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when VhpiRightBoundP => + if Obj.Kind /= VhpiIntRangeK then + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Right; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT) + is + begin + case Property is + when VhpiIsUpP => + if Obj.Kind /= VhpiIntRangeK then + Res := False; + Error := AvhpiErrorBadRel; + return; + end if; + Error := AvhpiErrorOk; + case Get_Base_Type (Obj.Rng_Type).Kind is + when Ghdl_Rtik_Type_I32 => + Res := Obj.Rng_Addr.I32.Dir = Dir_To; + when others => + Error := AvhpiErrorNotImplemented; + end case; + return; + when others => + Error := AvhpiErrorNotImplemented; + end case; + end Vhpi_Get; + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT + is + begin + case Obj.Kind is + when VhpiArchBodyK => + return VhpiArchitectureEC; + when others => + return VhpiErrorEC; + end case; + end Vhpi_Get_EntityClass; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT is + begin + return Obj.Kind; + end Vhpi_Get_Kind; + + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT is + begin + case Obj.Kind is + when VhpiPortDeclK => + case Obj.Obj.Common.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + return VhpiInMode; + when Ghdl_Rti_Signal_Mode_Out => + return VhpiOutMode; + when Ghdl_Rti_Signal_Mode_Inout => + return VhpiInoutMode; + when Ghdl_Rti_Signal_Mode_Buffer => + return VhpiBufferMode; + when Ghdl_Rti_Signal_Mode_Linkage => + return VhpiLinkageMode; + when others => + return VhpiErrorMode; + end case; + when others => + return VhpiErrorMode; + end case; + end Vhpi_Get_Mode; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access is + begin + case Obj.Kind is + when VhpiSubtypeIndicK + | VhpiEnumTypeDeclK => + return Obj.Atype; + when VhpiSigDeclK + | VhpiPortDeclK => + return To_Ghdl_Rti_Access (Obj.Obj); + when others => + return null; + end case; + end Avhpi_Get_Rti; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address is + begin + case Obj.Kind is + when VhpiPortDeclK + | VhpiSigDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + return Loc_To_Addr (Obj.Ctxt.Block.Depth, + Obj.Obj.Loc, + Obj.Ctxt); + when others => + return Null_Address; + end case; + end Avhpi_Get_Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context is + begin + return Obj.Ctxt; + end Avhpi_Get_Context; + + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean + is + begin + if Hdl1.Kind /= Hdl2.Kind then + return False; + end if; + case Hdl1.Kind is + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiPhysTypeDeclK => + return Hdl1.Atype = Hdl2.Atype; + when others => + -- FIXME: todo + Internal_Error ("vhpi_compare_handles"); + end case; + end Vhpi_Compare_Handles; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT + is + Vptr : Ghdl_Value_Ptr; + Atype : Ghdl_Rti_Access; + begin + case Obj.Kind is + when VhpiIndexedNameK => + Vptr := To_Ghdl_Value_Ptr (Obj.N_Addr); + Atype := Obj.N_Type; + when others => + return AvhpiErrorNotImplemented; + end case; + case Get_Base_Type (Atype).Kind is + when Ghdl_Rtik_Type_P64 => + null; + when others => + return AvhpiErrorHandle; + end case; + Vptr.I64 := Val; + return AvhpiErrorOk; + end Vhpi_Put_Value; +end Grt.Avhpi; + + diff --git a/src/translate/grt/grt-avhpi.ads b/src/translate/grt/grt-avhpi.ads new file mode 100644 index 0000000..1eff5a8 --- /dev/null +++ b/src/translate/grt/grt-avhpi.ads @@ -0,0 +1,561 @@ +-- GHDL Run Time (GRT) - VHPI implementation for Ada. +-- 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. + +-- Ada oriented implementation of VHPI. +-- This doesn't follow exactly what VHPI defined, but: +-- * it should be easy to write a VHPI interface from this implementation. +-- * this implementation is thread-safe (no global storage). +-- * this implementation never allocates memory. +with System; use System; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Avhpi is + -- Object Kinds. + type VhpiClassKindT is + ( + VhpiUndefined, + VhpiAccessTypeDeclK, + VhpiAggregateK, + VhpiAliasDeclK, + VhpiAllLiteralK, + VhpiAllocatorK, + VhpiAnyCollectionK, + VhpiArchBodyK, + VhpiArgvK, + VhpiArrayTypeDeclK, + VhpiAssertStmtK, + VhpiAssocElemK, + VhpiAttrDeclK, + VhpiAttrSpecK, + VhpiBinaryExprK, + VhpiBitStringLiteralK, + VhpiBlockConfigK, + VhpiBlockStmtK, + VhpiBranchK, + VhpiCallbackK, + VhpiCaseStmtK, + VhpiCharLiteralK, + VhpiCompConfigK, + VhpiCompDeclK, + VhpiCompInstStmtK, + VhpiCondSigAssignStmtK, + VhpiCondWaveformK, + VhpiConfigDeclK, + VhpiConstDeclK, + VhpiConstParamDeclK, + VhpiConvFuncK, + VhpiDeRefObjK, + VhpiDisconnectSpecK, + VhpiDriverK, + VhpiDriverCollectionK, + VhpiElemAssocK, + VhpiElemDeclK, + VhpiEntityClassEntryK, + VhpiEntityDeclK, + VhpiEnumLiteralK, + VhpiEnumRangeK, + VhpiEnumTypeDeclK, + VhpiExitStmtK, + VhpiFileDeclK, + VhpiFileParamDeclK, + VhpiFileTypeDeclK, + VhpiFloatRangeK, + VhpiFloatTypeDeclK, + VhpiForGenerateK, + VhpiForLoopK, + VhpiForeignfK, + VhpiFuncCallK, + VhpiFuncDeclK, + VhpiGenericDeclK, + VhpiGroupDeclK, + VhpiGroupTempDeclK, + VhpiIfGenerateK, + VhpiIfStmtK, + VhpiInPortK, + VhpiIndexedNameK, + VhpiIntLiteralK, + VhpiIntRangeK, + VhpiIntTypeDeclK, + VhpiIteratorK, + VhpiLibraryDeclK, + VhpiLoopStmtK, + VhpiNextStmtK, + VhpiNullLiteralK, + VhpiNullStmtK, + VhpiOperatorK, + VhpiOthersLiteralK, + VhpiOutPortK, + VhpiPackBodyK, + VhpiPackDeclK, + VhpiPackInstK, + VhpiParamAttrNameK, + VhpiPhysLiteralK, + VhpiPhysRangeK, + VhpiPhysTypeDeclK, + VhpiPortDeclK, + VhpiProcCallStmtK, + VhpiProcDeclK, + VhpiProcessStmtK, + VhpiProtectedTypeK, + VhpiProtectedTypeBodyK, + VhpiProtectedTypeDeclK, + VhpiRealLiteralK, + VhpiRecordTypeDeclK, + VhpiReportStmtK, + VhpiReturnStmtK, + VhpiRootInstK, + VhpiSelectSigAssignStmtK, + VhpiSelectWaveformK, + VhpiSelectedNameK, + VhpiSigDeclK, + VhpiSigParamDeclK, + VhpiSimpAttrNameK, + VhpiSimpleSigAssignStmtK, + VhpiSliceNameK, + VhpiStringLiteralK, + VhpiSubpBodyK, + VhpiSubtypeDeclK, + VhpiSubtypeIndicK, + VhpiToolK, + VhpiTransactionK, + VhpiTypeConvK, + VhpiUnaryExprK, + VhpiUnitDeclK, + VhpiUserAttrNameK, + VhpiVarAssignStmtK, + VhpiVarDeclK, + VhpiVarParamDeclK, + VhpiWaitStmtK, + VhpiWaveformElemK, + VhpiWhileLoopK, + + -- Iterator, but on a name. + AvhpiNameIteratorK + ); + + type VhpiOneToOneT is + ( + VhpiAbstractLiteral, + VhpiActual, + VhpiAllLiteral, + VhpiAttrDecl, + VhpiAttrSpec, + VhpiBaseType, + VhpiBaseUnit, + VhpiBasicSignal, + VhpiBlockConfig, + VhpiCaseExpr, + VhpiCondExpr, + VhpiConfigDecl, + VhpiConfigSpec, + VhpiConstraint, + VhpiContributor, + VhpiCurCallback, + VhpiCurEqProcess, + VhpiCurStackFrame, + VhpiDeRefObj, + VhpiDecl, + VhpiDesignUnit, + VhpiDownStack, + VhpiElemSubtype, + VhpiEntityAspect, + VhpiEntityDecl, + VhpiEqProcessStmt, + VhpiExpr, + VhpiFormal, + VhpiFuncDecl, + VhpiGroupTempDecl, + VhpiGuardExpr, + VhpiGuardSig, + VhpiImmRegion, + VhpiInPort, + VhpiInitExpr, + VhpiIterScheme, + VhpiLeftExpr, + VhpiLexicalScope, + VhpiLhsExpr, + VhpiLocal, + VhpiLogicalExpr, + VhpiName, + VhpiOperator, + VhpiOthersLiteral, + VhpiOutPort, + VhpiParamDecl, + VhpiParamExpr, + VhpiParent, + VhpiPhysLiteral, + VhpiPrefix, + VhpiPrimaryUnit, + VhpiProtectedTypeBody, + VhpiProtectedTypeDecl, + VhpiRejectTime, + VhpiReportExpr, + VhpiResolFunc, + VhpiReturnExpr, + VhpiReturnTypeMark, + VhpiRhsExpr, + VhpiRightExpr, + VhpiRootInst, + VhpiSelectExpr, + VhpiSeverityExpr, + VhpiSimpleName, + VhpiSubpBody, + VhpiSubpDecl, + VhpiSubtype, + VhpiSuffix, + VhpiTimeExpr, + VhpiTimeOutExpr, + VhpiTool, + VhpiTypeMark, + VhpiUnitDecl, + VhpiUpStack, + VhpiUpperRegion, + VhpiValExpr, + VhpiValSubtype + ); + + -- Methods used to traverse 1 to many relationships. + type VhpiOneToManyT is + ( + VhpiAliasDecls, + VhpiArgvs, + VhpiAttrDecls, + VhpiAttrSpecs, + VhpiBasicSignals, + VhpiBlockStmts, + VhpiBranchs, + VhpiCallbacks, + VhpiChoices, + VhpiCompInstStmts, + VhpiCondExprs, + VhpiCondWaveforms, + VhpiConfigItems, + VhpiConfigSpecs, + VhpiConstDecls, + VhpiConstraints, + VhpiContributors, + VhpiCurRegions, + VhpiDecls, + VhpiDepUnits, + VhpiDesignUnits, + VhpiDrivenSigs, + VhpiDrivers, + VhpiElemAssocs, + VhpiEntityClassEntrys, + VhpiEntityDesignators, + VhpiEnumLiterals, + VhpiForeignfs, + VhpiGenericAssocs, + VhpiGenericDecls, + VhpiIndexExprs, + VhpiIndexedNames, + VhpiInternalRegions, + VhpiMembers, + VhpiPackInsts, + VhpiParamAssocs, + VhpiParamDecls, + VhpiPortAssocs, + VhpiPortDecls, + VhpiRecordElems, + VhpiSelectWaveforms, + VhpiSelectedNames, + VhpiSensitivitys, + VhpiSeqStmts, + VhpiSigAttrs, + VhpiSigDecls, + VhpiSigNames, + VhpiSignals, + VhpiSpecNames, + VhpiSpecs, + VhpiStmts, + VhpiTransactions, + VhpiTypeMarks, + VhpiUnitDecls, + VhpiUses, + VhpiVarDecls, + VhpiWaveformElems, + VhpiLibraryDecls + ); + + type VhpiIntPropertyT is + ( + VhpiAccessP, + VhpiArgcP, + VhpiAttrKindP, + VhpiBaseIndexP, + VhpiBeginLineNoP, + VhpiEndLineNoP, + VhpiEntityClassP, + VhpiForeignKindP, + VhpiFrameLevelP, + VhpiGenerateIndexP, + VhpiIntValP, + VhpiIsAnonymousP, + VhpiIsBasicP, + VhpiIsCompositeP, + VhpiIsDefaultP, + VhpiIsDeferredP, + VhpiIsDiscreteP, + VhpiIsForcedP, + VhpiIsForeignP, + VhpiIsGuardedP, + VhpiIsImplicitDeclP, + VhpiIsInvalidP_DEPRECATED, + VhpiIsLocalP, + VhpiIsNamedP, + VhpiIsNullP, + VhpiIsOpenP, + VhpiIsPLIP, + VhpiIsPassiveP, + VhpiIsPostponedP, + VhpiIsProtectedTypeP, + VhpiIsPureP, + VhpiIsResolvedP, + VhpiIsScalarP, + VhpiIsSeqStmtP, + VhpiIsSharedP, + VhpiIsTransportP, + VhpiIsUnaffectedP, + VhpiIsUnconstrainedP, + VhpiIsUninstantiatedP, + VhpiIsUpP, + VhpiIsVitalP, + VhpiIteratorTypeP, + VhpiKindP, + VhpiLeftBoundP, + VhpiLevelP_DEPRECATED, + VhpiLineNoP, + VhpiLineOffsetP, + VhpiLoopIndexP, + VhpiModeP, + VhpiNumDimensionsP, + VhpiNumFieldsP_DEPRECATED, + VhpiNumGensP, + VhpiNumLiteralsP, + VhpiNumMembersP, + VhpiNumParamsP, + VhpiNumPortsP, + VhpiOpenModeP, + VhpiPhaseP, + VhpiPositionP, + VhpiPredefAttrP, + VhpiReasonP, + VhpiRightBoundP, + VhpiSigKindP, + VhpiSizeP, + VhpiStartLineNoP, + VhpiStateP, + VhpiStaticnessP, + VhpiVHDLversionP, + VhpiIdP, + VhpiCapabilitiesP + ); + + -- String properties. + type VhpiStrPropertyT is + ( + VhpiCaseNameP, + VhpiCompNameP, + VhpiDefNameP, + VhpiFileNameP, + VhpiFullCaseNameP, + VhpiFullNameP, + VhpiKindStrP, + VhpiLabelNameP, + VhpiLibLogicalNameP, + VhpiLibPhysicalNameP, + VhpiLogicalNameP, + VhpiLoopLabelNameP, + VhpiNameP, + VhpiOpNameP, + VhpiStrValP, + VhpiToolVersionP, + VhpiUnitNameP + ); + + -- Possible Errors. + type AvhpiErrorT is + ( + AvhpiErrorOk, + AvhpiErrorBadRel, + AvhpiErrorHandle, + AvhpiErrorNotImplemented, + AvhpiErrorIteratorEnd, + AvhpiErrorBadIndex + ); + + type VhpiHandleT is private; + + -- A null handle. + Null_Handle : constant VhpiHandleT; + + -- Get the root instance. + procedure Get_Root_Inst (Res : out VhpiHandleT); + + -- Get the instanciated packages. + procedure Get_Package_Inst (Res : out VhpiHandleT); + + procedure Vhpi_Handle (Rel : VhpiOneToOneT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Handle_By_Index (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Index : Natural; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Iterator (Rel : VhpiOneToManyT; + Ref : VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT); + + procedure Vhpi_Get_Str (Property : VhpiStrPropertyT; + Obj : VhpiHandleT; + Res : out String; + Len : out Natural); + + subtype VhpiIntT is Ghdl_I32; + + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out VhpiIntT; + Error : out AvhpiErrorT); + procedure Vhpi_Get (Property : VhpiIntPropertyT; + Obj : VhpiHandleT; + Res : out Boolean; + Error : out AvhpiErrorT); + + -- Almost the same as Vhpi_Get_Str (VhpiName, OBJ), but there is not + -- indexes for generate stmt. + function Avhpi_Get_Base_Name (Obj : VhpiHandleT) return Ghdl_C_String; + + -- Return TRUE iff HDL1 and HDL2 are equivalent. + function Vhpi_Compare_Handles (Hdl1, Hdl2 : VhpiHandleT) + return Boolean; + +-- procedure Vhpi_Handle_By_Simple_Name (Ref : VhpiHandleT; +-- Res : out VhpiHandleT; +-- Error : out AvhpiErrorT); + + type VhpiEntityClassT is + ( + VhpiErrorEC, + VhpiEntityEC, + VhpiArchitectureEC, + VhpiConfigurationEC, + VhpiProcedureEC, + VhpiFunctionEC, + VhpiPackageEC, + VhpiTypeEC, + VhpiSubtypeEC, + VhpiConstantEC, + VhpiSignalEC, + VhpiVariableEC, + VhpiComponentEC, + VhpiLabelEC, + VhpiLiteralEC, + VhpiUnitsEC, + VhpiFileEC, + VhpiGroupEC + ); + + function Vhpi_Get_EntityClass (Obj : VhpiHandleT) + return VhpiEntityClassT; + + type VhpiModeT is + ( + VhpiErrorMode, + VhpiInMode, + VhpiOutMode, + VhpiInoutMode, + VhpiBufferMode, + VhpiLinkageMode + ); + function Vhpi_Get_Mode (Obj : VhpiHandleT) return VhpiModeT; + + function Avhpi_Get_Rti (Obj : VhpiHandleT) return Ghdl_Rti_Access; + + function Avhpi_Get_Address (Obj : VhpiHandleT) return Address; + + function Avhpi_Get_Context (Obj : VhpiHandleT) return Rti_Context; + + function Vhpi_Get_Kind (Obj : VhpiHandleT) return VhpiClassKindT; + + function Vhpi_Put_Value (Obj : VhpiHandleT; Val : Ghdl_I64) + return AvhpiErrorT; +private + type VhpiHandleT (Kind : VhpiClassKindT := VhpiUndefined) is record + -- Context. + Ctxt : Rti_Context; + + case Kind is + when VhpiIteratorK => + Rel : VhpiOneToManyT; + It_Cur : Ghdl_Index_Type; + It2 : Ghdl_Index_Type; + Max2 : Ghdl_Index_Type; + when AvhpiNameIteratorK + | VhpiIndexedNameK => + N_Addr : Address; + N_Type : Ghdl_Rti_Access; + N_Idx : Ghdl_Index_Type; + N_Obj : Ghdl_Rtin_Object_Acc; + when VhpiSigDeclK + | VhpiPortDeclK + | VhpiGenericDeclK + | VhpiConstDeclK => + Obj : Ghdl_Rtin_Object_Acc; + when VhpiSubtypeIndicK + | VhpiSubtypeDeclK + | VhpiArrayTypeDeclK + | VhpiEnumTypeDeclK + | VhpiPhysTypeDeclK => + Atype : Ghdl_Rti_Access; + when VhpiCompInstStmtK => + Inst : Ghdl_Rtin_Instance_Acc; + when VhpiIntRangeK + | VhpiEnumRangeK + | VhpiFloatRangeK + | VhpiPhysRangeK => + Rng_Type : Ghdl_Rti_Access; + Rng_Addr : Ghdl_Range_Ptr; + when others => + null; + end case; + -- Current Object. + --Obj : Ghdl_Rti_Access; + end record; + + Null_Handle : constant VhpiHandleT := (Kind => VhpiUndefined, + Ctxt => (Base => Null_Address, + Block => null)); +end Grt.Avhpi; diff --git a/src/translate/grt/grt-avls.adb b/src/translate/grt/grt-avls.adb new file mode 100644 index 0000000..7f13ed3 --- /dev/null +++ b/src/translate/grt/grt-avls.adb @@ -0,0 +1,249 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- 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.Avls is + function Get_Height (Tree: AVL_Tree; N : AVL_Nid) return Ghdl_I32 is + begin + if N = AVL_Nil then + return 0; + else + return Tree (N).Height; + end if; + end Get_Height; + + procedure Check_AVL (Tree : AVL_Tree; N : AVL_Nid) + is + L, R : AVL_Nid; + Lh, Rh : Ghdl_I32; + H : Ghdl_I32; + begin + if N = AVL_Nil then + return; + end if; + L := Tree (N).Left; + R := Tree (N).Right; + H := Get_Height (Tree, N); + if L = AVL_Nil and R = AVL_Nil then + if Get_Height (Tree, N) /= 1 then + Internal_Error ("check_AVL(1)"); + end if; + return; + elsif L = AVL_Nil then + Check_AVL (Tree, R); + if H /= Get_Height (Tree, R) + 1 or H > 2 then + Internal_Error ("check_AVL(2)"); + end if; + elsif R = AVL_Nil then + Check_AVL (Tree, L); + if H /= Get_Height (Tree, L) + 1 or H > 2 then + Internal_Error ("check_AVL(3)"); + end if; + else + Check_AVL (Tree, L); + Check_AVL (Tree, R); + Lh := Get_Height (Tree, L); + Rh := Get_Height (Tree, R); + if Ghdl_I32'Max (Lh, Rh) + 1 /= H then + Internal_Error ("check_AVL(4)"); + end if; + if Rh - Lh > 1 or Rh - Lh < -1 then + Internal_Error ("check_AVL(5)"); + end if; + end if; + end Check_AVL; + + procedure Compute_Height (Tree : in out AVL_Tree; N : AVL_Nid) + is + begin + Tree (N).Height := + Ghdl_I32'Max (Get_Height (Tree, Tree (N).Left), + Get_Height (Tree, Tree (N).Right)) + 1; + end Compute_Height; + + procedure Simple_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + V : AVL_Value; + begin + -- Rotate nodes. + R := Tree (N).Right; + Tree (N).Right := Tree (R).Right; + Tree (R).Right := Tree (R).Left; + Tree (R).Left := Tree (N).Left; + Tree (N).Left := R; + -- Swap vals. + V := Tree (N).Val; + Tree (N).Val := Tree (R).Val; + Tree (R).Val := V; + -- Adjust bal. + Compute_Height (Tree, R); + Compute_Height (Tree, N); + end Simple_Rotate_Right; + + procedure Simple_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + V : AVL_Value; + begin + L := Tree (N).Left; + Tree (N).Left := Tree (L).Left; + Tree (L).Left := Tree (L).Right; + Tree (L).Right := Tree (N).Right; + Tree (N).Right := L; + V := Tree (N).Val; + Tree (N).Val := Tree (L).Val; + Tree (L).Val := V; + Compute_Height (Tree, L); + Compute_Height (Tree, N); + end Simple_Rotate_Left; + + procedure Double_Rotate_Right (Tree : in out AVL_Tree; N : AVL_Nid) + is + R : AVL_Nid; + begin + R := Tree (N).Right; + Simple_Rotate_Left (Tree, R); + Simple_Rotate_Right (Tree, N); + end Double_Rotate_Right; + + procedure Double_Rotate_Left (Tree : in out AVL_Tree; N : AVL_Nid) + is + L : AVL_Nid; + begin + L := Tree (N).Left; + Simple_Rotate_Right (Tree, L); + Simple_Rotate_Left (Tree, N); + end Double_Rotate_Left; + + procedure Insert (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Nid; + N : AVL_Nid; + Res : out AVL_Nid) + is + Diff : Integer; + Op_Ch, Ch : AVL_Nid; + begin + Diff := Cmp.all (Tree (Val).Val, Tree (N).Val); + if Diff = 0 then + Res := N; + return; + end if; + if Diff < 0 then + if Tree (N).Left = AVL_Nil then + Tree (N).Left := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Left; + Op_Ch := Tree (N).Right; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Left) + > Get_Height (Tree, Tree (Ch).Right) + then + Simple_Rotate_Left (Tree, N); + else + Double_Rotate_Left (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + else + if Tree (N).Right = AVL_Nil then + Tree (N).Right := Val; + Compute_Height (Tree, N); + -- N is balanced. + Res := Val; + else + Ch := Tree (N).Right; + Op_Ch := Tree (N).Left; + Insert (Tree, Cmp, Val, Ch, Res); + if Res /= Val then + return; + end if; + if Get_Height (Tree, Ch) - Get_Height (Tree, Op_Ch) = 2 then + -- Rotate + if Get_Height (Tree, Tree (Ch).Right) + > Get_Height (Tree, Tree (Ch).Left) + then + Simple_Rotate_Right (Tree, N); + else + Double_Rotate_Right (Tree, N); + end if; + else + Compute_Height (Tree, N); + end if; + end if; + end if; + end Insert; + + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid) + is + begin + if Tree'First /= AVL_Root or N /= Tree'Last then + Internal_Error ("avls.get_node"); + end if; + Insert (Tree, Cmp, N, AVL_Root, Res); + Check_AVL (Tree, AVL_Root); + end Get_Node; + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid + is + N : AVL_Nid; + Diff : Integer; + begin + N := AVL_Root; + if Tree'Last < AVL_Root then + return AVL_Nil; + end if; + loop + Diff := Cmp.all (Val, Tree (N).Val); + if Diff = 0 then + return N; + end if; + if Diff < 0 then + N := Tree (N).Left; + else + N := Tree (N).Right; + end if; + if N = AVL_Nil then + return AVL_Nil; + end if; + end loop; + end Find_Node; +end Grt.Avls; diff --git a/src/translate/grt/grt-avls.ads b/src/translate/grt/grt-avls.ads new file mode 100644 index 0000000..790053c --- /dev/null +++ b/src/translate/grt/grt-avls.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - binary balanced tree. +-- 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.Types; use Grt.Types; + +package Grt.Avls is + -- Implementation of a binary balanced tree. + -- This package is very generic, and provides only the algorithm. + -- The user must provide the storage of the tree. + -- The basic types of this implementation ares: + -- * AVL_Value: the value stored in the tree. This is an integer on 32 + -- bits. However, they may either really represent integers or an index + -- into another table. To compare two values, a user function is always + -- provided. + -- * AVL_Nid: a node id or an index into the tree. + -- * AVL_Node: a node, indexed by AVL_Nid. + -- * AVL_Tree: an array of AVL_Node, indexed by AVL_Nid. This represents + -- the tree. The root of the tree is always AVL_Root, which is the + -- first element of the array. + -- + -- As a choice, this package never allocate nodes. So, to insert a value + -- in the tree, the user must allocate an (empty) node, set the value of + -- the node and try to insert this node into the tree. If the value is + -- already in the tree, Get_Node will returns the node id which contains + -- the value. Otherwise, Get_Node returns the node just created by the + -- user. + + -- The value in an AVL tree. + -- This is fixed. + type AVL_Value is new Ghdl_I32; + + -- An AVL node id. + type AVL_Nid is new Ghdl_I32; + AVL_Nil : constant AVL_Nid := 0; + AVL_Root : constant AVL_Nid := 1; + + type AVL_Node is record + Val : AVL_Value; + Left : AVL_Nid; + Right : AVL_Nid; + Height : Ghdl_I32; + end record; + + type AVL_Tree is array (AVL_Nid range <>) of AVL_Node; + + -- Compare two values. + -- Returns < 0 if L < R, 0 if L = R, > 0 if L > R. + type AVL_Compare_Func is access function (L, R : AVL_Value) return Integer; + + -- Try to insert node N into TREE. + -- Returns either N or the node id of a node containing already the value. + procedure Get_Node (Tree : in out AVL_Tree; + Cmp : AVL_Compare_Func; + N : AVL_Nid; + Res : out AVL_Nid); + + function Find_Node (Tree : AVL_Tree; + Cmp : AVL_Compare_Func; + Val : AVL_Value) return AVL_Nid; + +end Grt.Avls; + + diff --git a/src/translate/grt/grt-c.ads b/src/translate/grt/grt-c.ads new file mode 100644 index 0000000..24003cf --- /dev/null +++ b/src/translate/grt/grt-c.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - C interface. +-- Copyright (C) 2005 - 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. + +-- This package declares C types. +-- It is a really stripped down version of interfaces.C! +with System; + +package Grt.C is + pragma Preelaborate (Grt.C); + + -- Type void * and char *. + subtype voids is System.Address; + subtype chars is System.Address; + subtype long is Long_Integer; + + -- Type size_t. + type size_t is mod 2 ** Standard'Address_Size; + + -- Type int. It is an alias on Integer for simplicity. + subtype int is Integer; + + -- Low level memory management. + procedure Free (Addr : System.Address); + function Malloc (Size : size_t) return System.Address; + function Realloc (Ptr : System.Address; Size : size_t) + return System.Address; + +private + pragma Import (C, Free); + pragma Import (C, Malloc); + pragma Import (C, Realloc); +end Grt.C; diff --git a/src/translate/grt/grt-cbinding.c b/src/translate/grt/grt-cbinding.c new file mode 100644 index 0000000..b95c0f0 --- /dev/null +++ b/src/translate/grt/grt-cbinding.c @@ -0,0 +1,99 @@ +/* GRT C bindings. + Copyright (C) 2002, 2003, 2004, 2005 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. +*/ +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +FILE * +__ghdl_get_stdout (void) +{ + return stdout; +} + +FILE * +__ghdl_get_stdin (void) +{ + return stdin; +} + +FILE * +__ghdl_get_stderr (void) +{ + return stderr; +} + +int +__ghdl_snprintf_g (char *buf, unsigned int len, double val) +{ + snprintf (buf, len, "%g", val); + return strlen (buf); +} + +void +__ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) +{ + snprintf (buf, len, "%.*f", ndigits, val); +} + +void +__ghdl_snprintf_fmtf (char *buf, unsigned int len, + const char *format, double v) +{ + snprintf (buf, len, format, v); +} + +void +__ghdl_fprintf_g (FILE *stream, double val) +{ + fprintf (stream, "%g", val); +} + +void +__ghdl_fprintf_clock (FILE *stream, int a, int b) +{ + fprintf (stream, "%3d.%03d", a, b); +} + +#ifndef WITH_GNAT_RUN_TIME +void +__gnat_last_chance_handler (void) +{ + abort (); +} + +void * +__gnat_malloc (size_t size) +{ + void *res; + res = malloc (size); + return res; +} + +void +__gnat_free (void *ptr) +{ + free (ptr); +} + +void * +__gnat_realloc (void *ptr, size_t size) +{ + return realloc (ptr, size); +} +#endif diff --git a/src/translate/grt/grt-cvpi.c b/src/translate/grt/grt-cvpi.c new file mode 100644 index 0000000..51edd67 --- /dev/null +++ b/src/translate/grt/grt-cvpi.c @@ -0,0 +1,277 @@ +/* GRT VPI C helpers. + Copyright (C) 2003, 2004, 2005 Tristan Gingold & Felix Bertram + + 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. +*/ +//----------------------------------------------------------------------------- +// Description: VPI interface for GRT runtime, "C" helpers +// the main purpose of this code is to interface with the +// Icarus Verilog Interactive (IVI) simulator GUI +//----------------------------------------------------------------------------- + +#include <stdio.h> +#include <stdlib.h> + +//----------------------------------------------------------------------------- +// VPI callback functions +typedef void *vpiHandle, *p_vpi_time, *p_vpi_value; +typedef struct t_cb_data { + int reason; + int (*cb_rtn)(struct t_cb_data*cb); + vpiHandle obj; + p_vpi_time time; + p_vpi_value value; + int index; + char*user_data; +} s_cb_data, *p_cb_data; + +//----------------------------------------------------------------------------- +// vpi thunking a la Icarus Verilog +#include <stdarg.h> +typedef void *s_vpi_time, *p_vpi_vlog_info, *p_vpi_error_info; +#define VPI_THUNK_MAGIC (0x87836BA5) +struct t_vpi_systf_data; +void vpi_register_systf (const struct t_vpi_systf_data*ss); +void vpi_vprintf (const char*fmt, va_list ap); +unsigned int vpi_mcd_close (unsigned int mcd); +char * vpi_mcd_name (unsigned int mcd); +unsigned int vpi_mcd_open (char *name); +unsigned int vpi_mcd_open_x (char *name, char *mode); +int vpi_mcd_vprintf (unsigned int mcd, const char*fmt, va_list ap); +int vpi_mcd_fputc (unsigned int mcd, unsigned char x); +int vpi_mcd_fgetc (unsigned int mcd); +vpiHandle vpi_register_cb (p_cb_data data); +int vpi_remove_cb (vpiHandle ref); +void vpi_sim_vcontrol (int operation, va_list ap); +vpiHandle vpi_handle (int type, vpiHandle ref); +vpiHandle vpi_iterate (int type, vpiHandle ref); +vpiHandle vpi_scan (vpiHandle iter); +vpiHandle vpi_handle_by_index (vpiHandle ref, int index); +void vpi_get_time (vpiHandle obj, s_vpi_time*t); +int vpi_get (int property, vpiHandle ref); +char* vpi_get_str (int property, vpiHandle ref); +void vpi_get_value (vpiHandle expr, p_vpi_value value); +vpiHandle vpi_put_value (vpiHandle obj, p_vpi_value value, + p_vpi_time when, int flags); +int vpi_free_object (vpiHandle ref); +int vpi_get_vlog_info (p_vpi_vlog_info vlog_info_p); +int vpi_chk_error (p_vpi_error_info info); +vpiHandle vpi_handle_by_name (char *name, vpiHandle scope); + +typedef struct { + int magic; + void (*vpi_register_systf) (const struct t_vpi_systf_data*ss); + void (*vpi_vprintf) (const char*fmt, va_list ap); + unsigned int (*vpi_mcd_close) (unsigned int mcd); + char* (*vpi_mcd_name) (unsigned int mcd); + unsigned int (*vpi_mcd_open) (char *name); + unsigned int (*vpi_mcd_open_x) (char *name, char *mode); + int (*vpi_mcd_vprintf) (unsigned int mcd, const char*fmt, va_list ap); + int (*vpi_mcd_fputc) (unsigned int mcd, unsigned char x); + int (*vpi_mcd_fgetc) (unsigned int mcd); + vpiHandle (*vpi_register_cb) (p_cb_data data); + int (*vpi_remove_cb) (vpiHandle ref); + void (*vpi_sim_vcontrol) (int operation, va_list ap); + vpiHandle (*vpi_handle) (int type, vpiHandle ref); + vpiHandle (*vpi_iterate) (int type, vpiHandle ref); + vpiHandle (*vpi_scan) (vpiHandle iter); + vpiHandle (*vpi_handle_by_index)(vpiHandle ref, int index); + void (*vpi_get_time) (vpiHandle obj, s_vpi_time*t); + int (*vpi_get) (int property, vpiHandle ref); + char* (*vpi_get_str) (int property, vpiHandle ref); + void (*vpi_get_value) (vpiHandle expr, p_vpi_value value); + vpiHandle (*vpi_put_value) (vpiHandle obj, p_vpi_value value, + p_vpi_time when, int flags); + int (*vpi_free_object) (vpiHandle ref); + int (*vpi_get_vlog_info) (p_vpi_vlog_info vlog_info_p); + int (*vpi_chk_error) (p_vpi_error_info info); + vpiHandle (*vpi_handle_by_name) (char *name, vpiHandle scope); +} vpi_thunk, *p_vpi_thunk; + +int vpi_register_sim(p_vpi_thunk tp); + +static vpi_thunk thunkTable = +{ VPI_THUNK_MAGIC, + vpi_register_systf, + vpi_vprintf, + vpi_mcd_close, + vpi_mcd_name, + vpi_mcd_open, + 0, //vpi_mcd_open_x, + 0, //vpi_mcd_vprintf, + 0, //vpi_mcd_fputc, + 0, //vpi_mcd_fgetc, + vpi_register_cb, + vpi_remove_cb, + 0, //vpi_sim_vcontrol, + vpi_handle, + vpi_iterate, + vpi_scan, + vpi_handle_by_index, + vpi_get_time, + vpi_get, + vpi_get_str, + vpi_get_value, + vpi_put_value, + vpi_free_object, + vpi_get_vlog_info, + 0, //vpi_chk_error, + 0 //vpi_handle_by_name +}; + +//----------------------------------------------------------------------------- +// VPI module load & startup +static void * module_open (const char *path); +static void * module_symbol (void *handle, const char *symbol); +static const char *module_error (void); + +#if defined(__WIN32__) +#include <windows.h> +static void * +module_open (const char *path) +{ + return (void *)LoadLibrary (path); +} + +static void * +module_symbol (void *handle, const char *symbol) +{ + return (void *)GetProcAddress ((HMODULE)handle, symbol); +} + +static const char * +module_error (void) +{ + static char msg[256]; + + FormatMessage + (FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + GetLastError (), + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &msg, + sizeof (msg) - 1, + NULL); + return msg; +} +#else +#include <dlfcn.h> +static void * +module_open (const char *path) +{ + return dlopen (path, RTLD_LAZY); +} + +static void * +module_symbol (void *handle, const char *symbol) +{ + return dlsym (handle, symbol); +} + +static const char * +module_error (void) +{ + return dlerror (); +} +#endif + +int +loadVpiModule (const char* modulename) +{ + static const char * const vpitablenames[] = + { + "_vlog_startup_routines", // with leading underscore: MacOSX + "vlog_startup_routines" // w/o leading underscore: Linux + }; + static const char * const vpithunknames[] = + { + "_vpi_register_sim", // with leading underscore: MacOSX + "vpi_register_sim" // w/o leading underscore: Linux + }; + + int i; + void* vpimod; + + fprintf (stderr, "loading VPI module '%s'\n", modulename); + + vpimod = module_open (modulename); + + if (vpimod == NULL) + { + const char *msg; + + msg = module_error (); + + fprintf (stderr, "%s\n", msg == NULL ? "unknown dlopen error" : msg); + return -1; + } + + for (i = 0; i < 2; i++) // try with and w/o leading underscores + { + void* vpithunk; + void* vpitable; + + vpitable = module_symbol (vpimod, vpitablenames[i]); + vpithunk = module_symbol (vpimod, vpithunknames[i]); + + if (vpithunk) + { + typedef int (*funT)(p_vpi_thunk tp); + funT regsim; + + regsim = (funT)vpithunk; + regsim (&thunkTable); + } + else + { + // this is not an error, as the register-mechanism + // is not standardized + } + + if (vpitable) + { + unsigned int tmp; + //extern void (*vlog_startup_routines[])(); + typedef void (*vlog_startup_routines_t)(void); + vlog_startup_routines_t *vpifuns; + + vpifuns = (vlog_startup_routines_t*)vpitable; + for (tmp = 0; vpifuns[tmp]; tmp++) + { + vpifuns[tmp](); + } + + fprintf (stderr, "VPI module loaded!\n"); + return 0; // successfully registered VPI module + } + } + fprintf (stderr, "vlog_startup_routines not found\n"); + return -1; // failed to register VPI module +} + +void +vpi_printf (const char *fmt, ...) +{ + va_list params; + + va_start (params, fmt); + vprintf (fmt, params); + va_end (params); +} + +//----------------------------------------------------------------------------- +// end of file + diff --git a/src/translate/grt/grt-disp.adb b/src/translate/grt/grt-disp.adb new file mode 100644 index 0000000..e68b116 --- /dev/null +++ b/src/translate/grt/grt-disp.adb @@ -0,0 +1,227 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- 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.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +--with Grt.Errors; use Grt.Errors; + +package body Grt.Disp is + +-- procedure Put_Trim (Stream : FILEs; Str : String) +-- is +-- Start : Natural; +-- begin +-- Start := Str'First; +-- while Start <= Str'Last and then Str (Start) = ' ' loop +-- Start := Start + 1; +-- end loop; +-- Put (Stream, Str (Start .. Str'Last)); +-- end Put_Trim; + +-- procedure Put_E8 (Stream : FILEs; E8 : Ghdl_E8; Type_Desc : Ghdl_Desc_Ptr) +-- is +-- begin +-- Put_Str_Len (Stream, Type_Desc.E8.Values (Natural (E8))); +-- end Put_E8; + + --procedure Put_E32 + -- (Stream : FILEs; E32 : Ghdl_E32; Type_Desc : Ghdl_Desc_Ptr) + --is + --begin + -- Put_Str_Len (Stream, Type_Desc.E32.Values (Natural (E32))); + --end Put_E32; + + procedure Put_Sig_Index (Sig : Sig_Table_Index) + is + begin + Put_I32 (stdout, Ghdl_I32 (Sig)); + end Put_Sig_Index; + + procedure Put_Sig_Range (Sig : Sig_Table_Range) + is + begin + Put_Sig_Index (Sig.First); + if Sig.Last /= Sig.First then + Put ("-"); + Put_Sig_Index (Sig.Last); + end if; + end Put_Sig_Range; + + procedure Disp_Now + is + begin + Put ("Now is "); + Put_Time (stdout, Current_Time); + Put (" +"); + Put_I32 (stdout, Ghdl_I32 (Current_Delta)); + New_Line; + end Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type) + is + begin + case Kind is + when Drv_One_Driver => + Put ("Drv (1 drv) "); + when Eff_One_Driver => + Put ("Eff (1 drv) "); + when Drv_One_Port => + Put ("Drv (1 prt) "); + when Eff_One_Port => + Put ("Eff (1 prt) "); + when Imp_Forward => + Put ("Forward "); + when Imp_Forward_Build => + Put ("Forward_Build "); + when Imp_Guard => + Put ("Guard "); + when Imp_Stable => + Put ("Stable "); + when Imp_Quiet => + Put ("Quiet "); + when Imp_Transaction => + Put ("Transaction "); + when Imp_Delayed => + Put ("Delayed "); + when Eff_Actual => + Put ("Eff Actual "); + when Eff_Multiple => + Put ("Eff multiple "); + when Drv_One_Resolved => + Put ("Drv 1 resolved "); + when Eff_One_Resolved => + Put ("Eff 1 resolved "); + when In_Conversion => + Put ("In conv "); + when Out_Conversion => + Put ("Out conv "); + when Drv_Error => + Put ("Drv error "); + when Drv_Multiple => + Put ("Drv multiple "); + when Prop_End => + Put ("end "); + end case; + end Disp_Propagation_Kind; + + procedure Disp_Signals_Order is + begin + for I in Propagation.First .. Propagation.Last loop + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Disp_Propagation_Kind (Propagation.Table (I).Kind); + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Drv_One_Resolved + | Eff_One_Resolved + | Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Delayed + | Eff_Actual => + Put_Sig_Index (Signal_Ptr_To_Index (Propagation.Table (I).Sig)); + New_Line; + when Imp_Forward => + Put_I32 (stdout, Ghdl_I32 (Propagation.Table (I).Sig.Net)); + New_Line; + when Imp_Forward_Build => + declare + Forward : Forward_Build_Acc; + begin + Forward := Propagation.Table (I).Forward; + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Src)); + Put (" -> "); + Put_Sig_Index (Signal_Ptr_To_Index (Forward.Targ)); + New_Line; + end; + when Eff_Multiple + | Drv_Multiple => + Put_Sig_Range (Propagation.Table (I).Resolv.Sig_Range); + New_Line; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Propagation.Table (I).Conv; + Put_Sig_Range (Conv.Src); + Put (" -> "); + Put_Sig_Range (Conv.Dest); + New_Line; + end; + when Prop_End => + New_Line; + when Drv_Error => + null; + end case; + end loop; + end Disp_Signals_Order; + + procedure Disp_Mode (Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Put (" b1"); + when Mode_E8 => + Put (" e8"); + when Mode_E32 => + Put ("e32"); + when Mode_I32 => + Put ("i32"); + when Mode_I64 => + Put ("i64"); + when Mode_F64 => + Put ("f64"); + end case; + end Disp_Mode; + + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + if Value.B1 then + Put ("T"); + else + Put ("F"); + end if; + when Mode_E8 => + Put_I32 (stdout, Ghdl_I32 (Value.E8)); + when Mode_E32 => + Put_I32 (stdout, Ghdl_I32 (Value.E32)); + when Mode_I32 => + Put_I32 (stdout, Value.I32); + when Mode_I64 => + Put_I64 (stdout, Value.I64); + when Mode_F64 => + Put_F64 (stdout, Value.F64); + end case; + end Disp_Value; +end Grt.Disp; diff --git a/src/translate/grt/grt-disp.ads b/src/translate/grt/grt-disp.ads new file mode 100644 index 0000000..6c15b37 --- /dev/null +++ b/src/translate/grt/grt-disp.ads @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Common display subprograms. +-- 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.Signals; use Grt.Signals; +with Grt.Types; use Grt.Types; + +package Grt.Disp is + -- Display SIG number. + procedure Put_Sig_Index (Sig : Sig_Table_Index); + + -- Disp current time and current delta. + procedure Disp_Now; + + procedure Disp_Propagation_Kind (Kind : Propagation_Kind_Type); + + -- Disp signals propagation order. + procedure Disp_Signals_Order; + + -- Disp mode. + procedure Disp_Mode (Mode : Mode_Type); + + -- Disp value (numeric). + procedure Disp_Value (Value : Value_Union; Mode : Mode_Type); + +end Grt.Disp; diff --git a/src/translate/grt/grt-disp_rti.adb b/src/translate/grt/grt-disp_rti.adb new file mode 100644 index 0000000..08d27da --- /dev/null +++ b/src/translate/grt/grt-disp_rti.adb @@ -0,0 +1,1080 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- 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.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Disp_Rti is + procedure Disp_Kind (Kind : Ghdl_Rtik); + + procedure Disp_Name (Name : Ghdl_C_String) is + begin + if Name = null then + Put (stdout, "<anonymous>"); + else + Put (stdout, Name); + end if; + end Disp_Name; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Disp_Enum_Value + (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Put (Stream, Enum_Rti.Names (Val)); + end Disp_Enum_Value; + + procedure Disp_Scalar_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Addr : in out Address; + Is_Sig : Boolean) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + + Vptr : Ghdl_Value_Ptr; + begin + if Is_Sig then + Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all); + Update (Address'Size); + else + Vptr := To_Ghdl_Value_Ptr (Addr); + end if; + + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Put_I32 (Stream, Vptr.I32); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_E8 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_E32 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_B1 => + Disp_Enum_Value (Stream, Rti, + Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Vptr.F64); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Vptr.I64); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Vptr.I32); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (32); + end if; + when others => + Internal_Error ("disp_rti.disp_scalar_value"); + end case; + end Disp_Scalar_Value; + +-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik +-- is +-- Ndef : Ghdl_Rti_Access; +-- begin +-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then +-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; +-- else +-- Ndef := Rti; +-- end if; +-- case Ndef.Kind is +-- when Ghdl_Rtik_Type_I32 => +-- return Ndef.Kind; +-- when others => +-- return Ghdl_Rtik_Error; +-- end case; +-- end Get_Scalar_Type_Kind; + + procedure Disp_Array_Value_1 (Stream : FILEs; + El_Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type; + Obj : in out Address; + Is_Sig : Boolean) + is + Length : Ghdl_Index_Type; + begin + Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); + Put (Stream, "("); + for I in 1 .. Length loop + if I /= 1 then + Put (Stream, ", "); + end if; + if Index = Rngs'Last then + Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); + else + Disp_Array_Value_1 + (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); + end if; + end loop; + Put (Stream, ")"); + end Disp_Array_Value_1; + + procedure Disp_Array_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Vals : Ghdl_Uc_Array_Acc; + Is_Sig : Boolean) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + Obj : Address; + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Obj := Vals.Base; + Disp_Array_Value_1 + (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); + end Disp_Array_Value; + + procedure Disp_Record_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Obj : Address; + Is_Sig : Boolean) + is + El : Ghdl_Rtin_Element_Acc; + El_Addr : Address; + begin + Put (Stream, "("); + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Stream, El.Name); + Put (" => "); + if Is_Sig then + El_Addr := Obj + El.Sig_Off; + else + El_Addr := Obj + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + end if; + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); + end loop; + Put (")"); + -- FIXME: update ADDR. + end Disp_Record_Value; + + procedure Disp_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Disp_Scalar_Value + (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, + Obj, Is_Sig); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); + when Ghdl_Rtik_Type_Array => + Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, + To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + B : Address; + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + B := Obj; + Disp_Array_Value_1 + (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); + end; + when Ghdl_Rtik_Type_File => + declare + Vptr : Ghdl_Value_Ptr; + begin + Vptr := To_Ghdl_Value_Ptr (Obj); + Put (Stream, "File#"); + Put_I32 (Stream, Vptr.I32); + -- FIXME: update OBJ (not very useful since never in a + -- composite type). + end; + when Ghdl_Rtik_Type_Record => + Disp_Record_Value + (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); + when Ghdl_Rtik_Type_Protected => + Put (Stream, "Unhandled protected type"); + when others => + Put (Stream, "Unknown Rti Kind : "); + Disp_Kind(Rti.Kind); + end case; + -- Put_Line(":"); + end Disp_Value; + + procedure Disp_Kind (Kind : Ghdl_Rtik) is + begin + case Kind is + when Ghdl_Rtik_Top => + Put ("ghdl_rtik_top"); + when Ghdl_Rtik_Package => + Put ("ghdl_rtik_package"); + when Ghdl_Rtik_Package_Body => + Put ("ghdl_rtik_package_body"); + when Ghdl_Rtik_Entity => + Put ("ghdl_rtik_entity"); + when Ghdl_Rtik_Architecture => + Put ("ghdl_rtik_architecture"); + + when Ghdl_Rtik_Port => + Put ("ghdl_rtik_port"); + when Ghdl_Rtik_Generic => + Put ("ghdl_rtik_generic"); + when Ghdl_Rtik_Process => + Put ("ghdl_rtik_process"); + when Ghdl_Rtik_Component => + Put ("ghdl_rtik_component"); + when Ghdl_Rtik_Attribute => + Put ("ghdl_rtik_attribute"); + + when Ghdl_Rtik_Attribute_Quiet => + Put ("ghdl_rtik_attribute_quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put ("ghdl_rtik_attribute_stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put ("ghdl_rtik_attribute_transaction"); + + when Ghdl_Rtik_Constant => + Put ("ghdl_rtik_constant"); + when Ghdl_Rtik_Iterator => + Put ("ghdl_rtik_iterator"); + when Ghdl_Rtik_Signal => + Put ("ghdl_rtik_signal"); + when Ghdl_Rtik_Variable => + Put ("ghdl_rtik_variable"); + when Ghdl_Rtik_Guard => + Put ("ghdl_rtik_guard"); + when Ghdl_Rtik_File => + Put ("ghdl_rtik_file"); + + when Ghdl_Rtik_Instance => + Put ("ghdl_rtik_instance"); + when Ghdl_Rtik_Block => + Put ("ghdl_rtik_block"); + when Ghdl_Rtik_If_Generate => + Put ("ghdl_rtik_if_generate"); + when Ghdl_Rtik_For_Generate => + Put ("ghdl_rtik_for_generate"); + + when Ghdl_Rtik_Type_B1 => + Put ("ghdl_rtik_type_b1"); + when Ghdl_Rtik_Type_E8 => + Put ("ghdl_rtik_type_e8"); + when Ghdl_Rtik_Type_E32 => + Put ("ghdl_rtik_type_e32"); + when Ghdl_Rtik_Type_P64 => + Put ("ghdl_rtik_type_p64"); + when Ghdl_Rtik_Type_I32 => + Put ("ghdl_rtik_type_i32"); + + when Ghdl_Rtik_Type_Array => + Put ("ghdl_rtik_type_array"); + when Ghdl_Rtik_Subtype_Array => + Put ("ghdl_rtik_subtype_array"); + when Ghdl_Rtik_Type_Record => + Put ("ghdl_rtik_type_record"); + + when Ghdl_Rtik_Type_Access => + Put ("ghdl_rtik_type_access"); + when Ghdl_Rtik_Type_File => + Put ("ghdl_rtik_type_file"); + when Ghdl_Rtik_Type_Protected => + Put ("ghdl_rtik_type_protected"); + + when Ghdl_Rtik_Subtype_Scalar => + Put ("ghdl_rtik_subtype_scalar"); + + when Ghdl_Rtik_Element => + Put ("ghdl_rtik_element"); + when Ghdl_Rtik_Unit64 => + Put ("ghdl_rtik_unit64"); + when Ghdl_Rtik_Unitptr => + Put ("ghdl_rtik_unitptr"); + + when others => + Put ("ghdl_rtik_#"); + Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); + end case; + end Disp_Kind; + + procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is + begin + Put (", D="); + Put_I32 (stdout, Ghdl_I32 (Depth)); + end Disp_Depth; + + procedure Disp_Indent (Indent : Natural) is + begin + for I in 1 .. Indent loop + Put (' '); + end loop; + end Disp_Indent; + + -- Disp a subtype_indication. + -- OBJ may be necessary when the subtype is an unconstrained array type, + -- whose bounds are stored with the object. + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); + + procedure Disp_Range + (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr) + is + begin + case Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Rng.I32.Left); + Put_Dir (Stream, Rng.I32.Dir); + Put_I32 (Stream, Rng.I32.Right); + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Rng.F64.Left); + Put_Dir (Stream, Rng.F64.Dir); + Put_F64 (Stream, Rng.F64.Right); + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Rng.P64.Left); + Put_Dir (Stream, Rng.P64.Dir); + Put_I64 (Stream, Rng.P64.Right); + when others => + Put ("?Scal"); + end case; + end Disp_Range; + + procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Scalar_Type_Name (Rti.Basetype); + end if; + end; + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Put ("#disp_scalar_type_name#"); + end case; + end Disp_Scalar_Type_Name; + + procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; + Bounds_Ptr : Address) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + procedure Disp_Bounds (Def : Ghdl_Rti_Access) + is + Ndef : Ghdl_Rti_Access; + begin + if Bounds = Null_Address then + Put ("?"); + else + if Def.Kind = Ghdl_Rtik_Subtype_Scalar then + Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; + else + Ndef := Def; + end if; + case Ndef.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds)); + Update (Ghdl_Range_I32'Size); + when others => + Disp_Kind (Ndef.Kind); + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end Disp_Bounds; + begin + Disp_Name (Def.Name); + if Bounds_Ptr = Null_Address then + return; + end if; + Put (" ("); + Bounds := Bounds_Ptr; + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Scalar_Type_Name (Def.Indexes (I)); + Put (" range "); + Disp_Bounds (Def.Indexes (I)); + end loop; + Put (")"); + end Disp_Type_Array_Name; + + procedure Disp_Subtype_Scalar_Range + (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) + is + Range_Addr : Address; + Rng : Ghdl_Range_Ptr; + begin + Range_Addr := Loc_To_Addr (Def.Common.Depth, + Def.Range_Loc, Ctxt); + Rng := To_Ghdl_Range_Ptr (Range_Addr); + Disp_Range (Stream, Def.Basetype.Kind, Rng); + end Disp_Subtype_Scalar_Range; + + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) + is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Subtype_Indication + (Rti.Basetype, Null_Context, Null_Address); + Put (" range "); + Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); + end if; + end; + --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), + -- Base); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when Ghdl_Rtik_Type_File + | Ghdl_Rtik_Type_Access => + Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); + when Ghdl_Rtik_Type_Record => + Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); + when Ghdl_Rtik_Type_Array => + declare + Bounds : Address; + begin + if Obj = Null_Address then + Bounds := Null_Address; + else + Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; + end if; + Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), + Bounds); + end; + when Ghdl_Rtik_Subtype_Array => + declare + Sdef : Ghdl_Rtin_Subtype_Array_Acc; + begin + Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); + if Sdef.Name /= null then + Disp_Name (Sdef.Name); + else + Disp_Type_Array_Name + (Sdef.Basetype, + Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + end if; + end; + when Ghdl_Rtik_Type_Protected => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Disp_Kind (Def.Kind); + Put (' '); + end case; + end Disp_Subtype_Indication; + + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural); + + procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; + Arr : Ghdl_Rti_Arr_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + for I in 1 .. Nbr loop + Disp_Rti (Arr (I - 1), Ctxt, Indent); + end loop; + end Disp_Rti_Arr; + + procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Blk.Common.Kind); + Disp_Depth (Blk.Common.Depth); + Put (": "); + Disp_Name (Blk.Name); + New_Line; + if Blk.Parent /= null then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Disp entity. + Disp_Rti (Blk.Parent, Ctxt, Indent + 1); + when others => + null; + end case; + end if; + case Blk.Common.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := (Base => Ctxt.Base + Blk.Loc, + Block => To_Ghdl_Rti_Access (Blk)); + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + when Ghdl_Rtik_For_Generate => + declare + Length : Ghdl_Index_Type; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + Length := Get_For_Generate_Length (Blk, Ctxt); + for I in 1 .. Length loop + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + Nctxt.Base := Nctxt.Base + Blk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + if Nctxt.Base /= Null_Address then + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + end if; + when others => + Internal_Error ("disp_block"); + end case; + end Disp_Block; + + procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; + Is_Sig : Boolean; + Ctxt : Rti_Context; + Indent : Natural) + is + Addr : Address; + Obj_Type : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); + Obj_Type := Obj.Obj_Type; + Disp_Subtype_Indication (Obj_Type, Ctxt, Addr); + Put (" := "); + + -- FIXME: put this into a function. + if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array + or Obj_Type.Kind = Ghdl_Rtik_Type_Record) + and then Rti_Complex_Type (Obj_Type) + then + Addr := To_Addr_Acc (Addr).all; + end if; + Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); + New_Line; + end Disp_Object; + + procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); + New_Line; + end Disp_Attribute; + + procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Comp.Common.Kind); + Disp_Depth (Comp.Common.Depth); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); + end Disp_Component; + + procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Inst_Addr : Address; + Inst_Base : Address; + Inst_Rti : Ghdl_Rti_Access; + Nindent : Natural; + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Inst.Common.Kind); + Put (": "); + Disp_Name (Inst.Name); + New_Line; + + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + + Nindent := Indent + 1; + + case Inst.Instance.Kind is + when Ghdl_Rtik_Component => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + Disp_Indent (Nindent); + Disp_Kind (Comp.Common.Kind); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + -- Disp components generics and ports. + -- FIXME: the data to disp are at COMP_BASE. + Nctxt := (Base => Inst_Addr, + Block => Inst.Instance); + Nindent := Nindent + 1; + Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); + Nindent := Nindent + 1; + end; + when Ghdl_Rtik_Entity => + null; + when others => + null; + end case; + + -- Read instance RTI. + if Inst_Base /= Null_Address then + Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; + Nctxt := (Base => Inst_Base, + Block => Inst_Rti); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), + Nctxt, Nindent); + end if; + end Disp_Instance; + + procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Enum.Common.Kind); + Put (": "); + Disp_Name (Enum.Name); + Put (" is ("); + Disp_Name (Enum.Names (0)); + for I in 1 .. Enum.Nbr - 1 loop + Put (", "); + Disp_Name (Enum.Names (I)); + end loop; + Put (")"); + New_Line; + end Disp_Type_Enum_Decl; + + procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Bt : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Disp_Depth (Def.Common.Depth); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Bt := Def.Basetype; + case Bt.Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_F64 => + declare + Bdef : Ghdl_Rtin_Type_Scalar_Acc; + begin + Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + end; + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_P32 => + declare + Bdef : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + if Bdef.Name = Def.Name then + for I in 0 .. Bdef.Nbr - 1 loop + Unit := Bdef.Units (I); + New_Line; + Disp_Indent (Indent + 1); + Disp_Kind (Unit.Kind); + Put (": "); + Disp_Name (Get_Physical_Unit_Name (Unit)); + Put (" = "); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Put_I64 (stdout, + To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Bt.Kind is + when Ghdl_Rtik_Type_P64 => + Put_I64 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); + when Ghdl_Rtik_Type_P32 => + Put_I32 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + end loop; + end if; + end; + when others => + Disp_Subtype_Indication + (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); + end case; + New_Line; + end Disp_Subtype_Scalar_Decl; + + procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is array ("); + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); + Put (" range <>"); + end loop; + Put (") of "); + Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); + New_Line; + end Disp_Type_Array_Decl; + + procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Disp_Type_Array_Name + (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then + Put (" of "); + Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); + end if; + New_Line; + end Disp_Subtype_Array_Decl; + + procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + case Def.Common.Kind is + when Ghdl_Rtik_Type_Access => + Put ("access "); + when Ghdl_Rtik_Type_File => + Put ("file "); + when others => + Put ("?? "); + end case; + Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); + New_Line; + end Disp_Type_File_Or_Access; + + procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + El : Ghdl_Rtin_Element_Acc; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is record"); + New_Line; + for I in 1 .. Def.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); + Disp_Indent (Indent + 1); + Disp_Kind (El.Common.Kind); + Put (": "); + Disp_Name (El.Name); + Put (": "); + Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); + New_Line; + end loop; + end Disp_Type_Record; + + procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + pragma Unreferenced (Ctxt); + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is protected"); + New_Line; + end Disp_Type_Protected; + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + if Rti = null then + return; + end if; + + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Package + | Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_For_Generate => + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Package_Body => + Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); + when Ghdl_Rtik_Generic + | Ghdl_Rtik_Constant + | Ghdl_Rtik_Variable + | Ghdl_Rtik_Iterator + | Ghdl_Rtik_File => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); + when Ghdl_Rtik_Component => + Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); + when Ghdl_Rtik_Attribute => + Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Instance => + Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); + when Ghdl_Rtik_Subtype_Scalar => + Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), + Ctxt, Indent); + when Ghdl_Rtik_Type_Array => + Disp_Type_Array_Decl + (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Subtype_Array => + Disp_Subtype_Array_Decl + (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Access + | Ghdl_Rtik_Type_File => + Disp_Type_File_Or_Access + (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Record => + Disp_Type_Record + (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Protected => + Disp_Type_Protected + (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); + when others => + Disp_Indent (Indent); + Disp_Kind (Rti.Kind); + Put_Line (" ? "); + end case; + end Disp_Rti; + + Disp_Rti_Flag : Boolean := False; + + procedure Disp_All + is + Ctxt : Rti_Context; + begin + if not Disp_Rti_Flag then + return; + end if; + + Put ("DISP_RTI.Disp_All: "); + Disp_Kind (Ghdl_Rti_Top.Common.Kind); + New_Line; + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, + Ghdl_Rti_Top.Children, + Ctxt, 0); + Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); + + --Disp_Hierarchy; + end Disp_All; + + function Disp_Rti_Option (Opt : String) return Boolean + is + begin + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; + + procedure Disp_Rti_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; + + Disp_Rti_Hooks : aliased constant Hooks_Type := + (Option => Disp_Rti_Option'Access, + Help => Disp_Rti_Help'Access, + Init => null, + Start => Disp_All'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; + +end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_rti.ads b/src/translate/grt/grt-disp_rti.ads new file mode 100644 index 0000000..6033d20 --- /dev/null +++ b/src/translate/grt/grt-disp_rti.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- 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 Grt.Types; use Grt.Types; +with Grt.Stdio; use Grt.Stdio; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; + +package Grt.Disp_Rti is + -- Disp NAME. If NAME is null, then disp <anonymous>. + procedure Disp_Name (Name : Ghdl_C_String); + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean); + + procedure Register; +end Grt.Disp_Rti; diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb new file mode 100644 index 0000000..424d20d --- /dev/null +++ b/src/translate/grt/grt-disp_signals.adb @@ -0,0 +1,524 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- 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 System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +pragma Elaborate_All (Grt.Rtis_Utils); +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Options; +with Grt.Processes; +with Grt.Disp; use Grt.Disp; + +package body Grt.Disp_Signals is + procedure Foreach_Scalar_Signal + (Process : access procedure (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object)) + is + procedure Call_Process (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Rti_Object) is + begin + Process.all (Val_Addr, Val_Name, Val_Type, Param); + end Call_Process; + + pragma Inline (Call_Process); + + procedure Foreach_Scalar_Signal_Signal is new + Foreach_Scalar (Param_Type => Rti_Object, + Process => Call_Process); + + function Foreach_Scalar_Signal_Object + (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access) + return Traverse_Result + is + Sig : Ghdl_Rtin_Object_Acc; + begin + case Obj.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Sig := To_Ghdl_Rtin_Object_Acc (Obj); + Foreach_Scalar_Signal_Signal + (Ctxt, Sig.Obj_Type, + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, + Rti_Object'(Obj, Ctxt)); + when others => + null; + end case; + return Traverse_Ok; + end Foreach_Scalar_Signal_Object; + + function Foreach_Scalar_Signal_Traverse is + new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object); + + Res : Traverse_Result; + pragma Unreferenced (Res); + begin + Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context); + end Foreach_Scalar_Signal; + + procedure Disp_Context (Ctxt : Rti_Context) + is + Blk : Ghdl_Rtin_Block_Acc; + Nctxt : Rti_Context; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('.'); + Put (Blk.Name); + when Ghdl_Rtik_Entity => + Put (Blk.Name); + when Ghdl_Rtik_Architecture => + Nctxt := Get_Parent_Context (Ctxt); + Disp_Context (Nctxt); + Put ('('); + Put (Blk.Name); + Put (')'); + when others => + Internal_Error ("disp_context"); + end case; + end Disp_Context; + + -- This is a debugging procedure. + pragma Unreferenced (Disp_Context); + + -- Option --trace-signals. + + -- Disp transaction TRANS from signal SIG. + procedure Disp_Transaction (Trans : Transaction_Acc; + Sig_Type : Ghdl_Rti_Access; + Mode : Mode_Type) + is + T : Transaction_Acc; + begin + T := Trans; + loop + case T.Kind is + when Trans_Value => + if Sig_Type /= null then + Disp_Value (stdout, T.Val, Sig_Type); + else + Disp_Value (T.Val, Mode); + end if; + when Trans_Direct => + if Sig_Type /= null then + Disp_Value (stdout, T.Val_Ptr.all, Sig_Type); + else + Disp_Value (T.Val_Ptr.all, Mode); + end if; + when Trans_Null => + Put ("NULL"); + when Trans_Error => + Put ("ERROR"); + end case; + if T.Kind = Trans_Direct then + -- The Time field is not updated for direct transaction. + Put ("[DIRECT]"); + else + Put ("@"); + Put_Time (stdout, T.Time); + end if; + T := T.Next; + exit when T = null; + Put (", "); + end loop; + end Disp_Transaction; + + procedure Disp_Simple_Signal + (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean) + is + function To_Address is new Ada.Unchecked_Conversion + (Source => Resolved_Signal_Acc, Target => Address); + begin + Put (' '); + Put (stdout, Sig.all'Address); + Put (' '); + Disp_Mode (Sig.Mode); + Put (' '); + if Sig.Active then + Put ('A'); + else + Put ('-'); + end if; + if Sig.Event then + Put ('E'); + else + Put ('-'); + end if; + if Sig.Has_Active then + Put ('a'); + else + Put ('-'); + end if; + if Sig.S.Effective /= null then + Put ('e'); + else + Put ('-'); + end if; + if Boolean'(True) then + Put (" last_event="); + Put_Time (stdout, Sig.Last_Event); + Put (" last_active="); + Put_Time (stdout, Sig.Last_Active); + end if; + Put (" val="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Value, Sig_Type); + else + Disp_Value (Sig.Value, Sig.Mode); + end if; + Put ("; drv="); + if Sig_Type /= null then + Disp_Value (stdout, Sig.Driving_Value, Sig_Type); + else + Disp_Value (Sig.Driving_Value, Sig.Mode); + end if; + if Sources then + if Sig.Nbr_Ports > 0 then + Put (';'); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + Put (" ports"); + end if; + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv /= null then + Put (stdout, " res func "); + Put (stdout, To_Address(Sig.S.Resolv)); + end if; + if Sig.S.Nbr_Drivers = 0 then + Put ("; no driver"); + elsif Sig.S.Nbr_Drivers = 1 then + Put ("; trans="); + Disp_Transaction + (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode); + else + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + New_Line; + Put (" "); + Disp_Transaction + (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode); + end loop; + end if; + end if; + end if; + New_Line; + end Disp_Simple_Signal; + + procedure Disp_Signal_Name (Stream : FILEs; + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc) is + begin + case Sig.Common.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, Sig.Name); + when Ghdl_Rtik_Attribute_Quiet => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put (stdout, Ctxt); + Put ("."); + Put (Stream, " 'transaction"); + when others => + null; + end case; + end Disp_Signal_Name; + + procedure Disp_Scalar_Signal (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + begin + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all), + Val_Type, Options.Disp_Sources); + end Disp_Scalar_Signal; + + + procedure Disp_All_Signals is + begin + Foreach_Scalar_Signal (Disp_Scalar_Signal'access); + end Disp_All_Signals; + + -- Option disp-sensitivity + + procedure Disp_Scalar_Sensitivity (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + Sig : Ghdl_Signal_Ptr; + + Action : Action_List_Acc; + begin + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig.Flags.Seen then + return; + else + Sig.Flags.Seen := True; + end if; + Disp_Signal_Name (stdout, Parent.Ctxt, + To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + New_Line (stdout); + + Action := Sig.Event_List; + while Action /= null loop + Put (stdout, " wakeup "); + Grt.Processes.Disp_Process_Name (stdout, Action.Proc); + New_Line (stdout); + Action := Action.Next; + end loop; + + if Sig.S.Mode_Sig in Mode_Signal_User then + for I in 1 .. Sig.S.Nbr_Drivers loop + Put (stdout, " driven "); + Grt.Processes.Disp_Process_Name + (stdout, Sig.S.Drivers (I - 1).Proc); + New_Line (stdout); + end loop; + end if; + end Disp_Scalar_Sensitivity; + + procedure Disp_All_Sensitivity is + begin + Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access); + end Disp_All_Sensitivity; + + + -- Option disp-signals-map + + procedure Disp_Signals_Map_Scalar (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Parent : Rti_Object) + is + pragma Unreferenced (Val_Type); + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Signal_Ptr); + + S : Ghdl_Signal_Ptr; + begin + Disp_Signal_Name (stdout, + Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj)); + Put (stdout, Val_Name); + Put (": "); + S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + Put (stdout, S.all'Address); + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (S.Net)); + if S.Has_Active then + Put (" +A"); + end if; + New_Line; + end Disp_Signals_Map_Scalar; + + procedure Disp_Signals_Map is + begin + Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access); + end Disp_Signals_Map; + + -- Option --disp-signals-table + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type) + is + begin + case Mode is + when Mode_Signal => + Put ("signal"); + when Mode_Linkage => + Put ("linkage"); + when Mode_Buffer => + Put ("buffer"); + when Mode_Out => + Put ("out"); + when Mode_Inout => + Put ("inout"); + when Mode_In => + Put ("in"); + when Mode_Stable => + Put ("stable"); + when Mode_Quiet => + Put ("quiet"); + when Mode_Transaction => + Put ("transaction"); + when Mode_Delayed => + Put ("delayed"); + when Mode_Guard => + Put ("guard"); + when Mode_Conv_In => + Put ("conv_in"); + when Mode_Conv_Out => + Put ("conv_out"); + when Mode_End => + Put ("end"); + end case; + end Disp_Mode_Signal; + + procedure Disp_Signals_Table + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + Put_Sig_Index (I); + Put (": "); + Put (stdout, Sig.all'Address); + if Sig.Has_Active then + Put (" +A"); + end if; + Put (" net: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Net)); + Put (" smode: "); + Disp_Mode_Signal (Sig.S.Mode_Sig); + Put (" #prt: "); + Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports)); + if Sig.S.Mode_Sig in Mode_Signal_User then + Put (" #drv: "); + Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers)); + if Sig.S.Effective /= null then + Put (" eff: "); + Put (stdout, Sig.S.Effective.all'Address); + end if; + if Sig.S.Resolv /= null then + Put (" resolved"); + end if; + end if; + if Boolean'(False) then + Put (" link: "); + Put (stdout, Sig.Link.all'Address); + end if; + New_Line; + if Sig.Nbr_Ports /= 0 then + for J in 1 .. Sig.Nbr_Ports loop + Put (" "); + Put (stdout, Sig.Ports (J - 1).all'Address); + end loop; + New_Line; + end if; + end loop; + Grt.Stdio.fflush (stdout); + end Disp_Signals_Table; + + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr) + is + begin + Disp_Simple_Signal (Sig, null, True); + end Disp_A_Signal; + + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr) + is + Found : Boolean := False; + Cur_Ctxt : Rti_Context; + Cur_Sig : Ghdl_Rtin_Object_Acc; + + procedure Process_Scalar (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Boolean) + is + pragma Unreferenced (Val_Type); + pragma Unreferenced (Param); + Sig1 : Ghdl_Signal_Ptr; + begin + -- Read the signal. + Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + if Sig1 = Sig and not Found then + Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig); + Put (Stream, Val_Name); + Found := True; + end if; + end Process_Scalar; + + procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar + (Param_Type => Boolean, Process => Process_Scalar); + + function Process_Block (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result + is + begin + case Obj.Kind is + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Transaction => + Cur_Ctxt := Ctxt; + Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj); + Foreach_Scalar + (Ctxt, Cur_Sig.Obj_Type, + Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt), + True, True); + if Found then + return Traverse_Stop; + end if; + when others => + null; + end case; + return Traverse_Ok; + end Process_Block; + + function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks + (Process_Block); + + Res_Status : Traverse_Result; + pragma Unreferenced (Res_Status); + begin + Res_Status := Foreach_Block (Get_Top_Context); + if not Found then + Put (Stream, "(unknown signal)"); + end if; + end Put_Signal_Name; + +end Grt.Disp_Signals; diff --git a/src/translate/grt/grt-disp_signals.ads b/src/translate/grt/grt-disp_signals.ads new file mode 100644 index 0000000..73bd60d --- /dev/null +++ b/src/translate/grt/grt-disp_signals.ads @@ -0,0 +1,48 @@ +-- GHDL Run Time (GRT) - Display subprograms for signals. +-- 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.Types; use Grt.Types; +with Grt.Signals; use Grt.Signals; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Disp_Signals is + procedure Disp_All_Signals; + + procedure Disp_Signals_Map; + + procedure Disp_Signals_Table; + + procedure Disp_All_Sensitivity; + + procedure Disp_Mode_Signal (Mode : Mode_Signal_Type); + + -- Disp informations on signal SIG. + -- To be used inside the debugger. + procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr); + + -- Put the full name of signal SIG. + -- This operation is really expensive, since the whole hierarchy is + -- traversed. + procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr); +end Grt.Disp_Signals; diff --git a/src/translate/grt/grt-disp_tree.adb b/src/translate/grt/grt-disp_tree.adb new file mode 100644 index 0000000..7d58119 --- /dev/null +++ b/src/translate/grt/grt-disp_tree.adb @@ -0,0 +1,461 @@ +-- GHDL Run Time (GRT) - Tree displayer. +-- 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 Grt.Disp_Rti; use Grt.Disp_Rti; +with Grt.Rtis; use Grt.Rtis; +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Types; use Grt.Types; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Disp_Tree is + -- Set by --disp-tree, to display the design hierarchy. + type Disp_Tree_Kind is + ( + Disp_Tree_None, -- Do not disp tree. + Disp_Tree_Inst, -- Disp entities, arch, package, blocks, components. + Disp_Tree_Proc, -- As above plus processes + Disp_Tree_Port -- As above plus ports and signals. + ); + Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None; + + + -- Get next interesting child. + procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; + Index : in out Ghdl_Index_Type; + Child : out Ghdl_Rti_Access) + is + begin + -- Exit if no more children. + while Index < Parent.Nbr_Child loop + Child := Parent.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_Instance => + return; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard => + if Disp_Tree_Flag >= Disp_Tree_Port then + return; + end if; + when Ghdl_Rtik_Process => + if Disp_Tree_Flag >= Disp_Tree_Proc then + return; + end if; + when others => + null; + end case; + end loop; + Child := null; + end Get_Tree_Child; + + procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Process + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + begin + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Package => + declare + Blk : Ghdl_Rtin_Block_Acc; + Lib : Ghdl_Rtin_Type_Scalar_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Rti); + if Rti.Kind = Ghdl_Rtik_Package_Body then + Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); + end if; + Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); + Disp_Name (Lib.Name); + Put ('.'); + Disp_Name (Blk.Name); + end; + when Ghdl_Rtik_For_Generate => + declare + Blk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Rti); + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Disp_Name (Blk.Name); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Put ('('); + Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); + Put (')'); + end; + when Ghdl_Rtik_Signal + | Ghdl_Rtik_Port + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Iterator => + Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); + when Ghdl_Rtik_Instance => + Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); + when others => + null; + end case; + + case Rti.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body => + Put (" [package]"); + when Ghdl_Rtik_Entity => + Put (" [entity]"); + when Ghdl_Rtik_Architecture => + Put (" [arch]"); + when Ghdl_Rtik_Process => + Put (" [process]"); + when Ghdl_Rtik_Block => + Put (" [block]"); + when Ghdl_Rtik_For_Generate => + Put (" [for-generate]"); + when Ghdl_Rtik_If_Generate => + Put (" [if-generate "); + if Ctxt.Base = Null_Address then + Put ("false]"); + else + Put ("true]"); + end if; + when Ghdl_Rtik_Signal => + Put (" [signal]"); + when Ghdl_Rtik_Port => + Put (" [port "); + case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is + when Ghdl_Rti_Signal_Mode_In => + Put ("in"); + when Ghdl_Rti_Signal_Mode_Out => + Put ("out"); + when Ghdl_Rti_Signal_Mode_Inout => + Put ("inout"); + when Ghdl_Rti_Signal_Mode_Buffer => + Put ("buffer"); + when Ghdl_Rti_Signal_Mode_Linkage => + Put ("linkage"); + when others => + Put ("?"); + end case; + Put ("]"); + when Ghdl_Rtik_Guard => + Put (" [guard]"); + when Ghdl_Rtik_Iterator => + Put (" [iterator]"); + when Ghdl_Rtik_Instance => + Put (" [instance]"); + when others => + null; + end case; + end Disp_Tree_Child; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + + procedure Disp_Tree_Block1 + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + Child : Ghdl_Rti_Access; + Child2 : Ghdl_Rti_Access; + Index : Ghdl_Index_Type; + + procedure Disp_Header (Nctxt : Rti_Context; + Force_Cont : Boolean := False) + is + begin + Put (Pfx); + + if Blk.Common.Kind /= Ghdl_Rtik_Entity + and Child2 = null + and Force_Cont = False + then + Put ("`-"); + else + Put ("+-"); + end if; + + Disp_Tree_Child (Child, Nctxt); + New_Line; + end Disp_Header; + + procedure Disp_Sub_Block + (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) + is + Npfx : String (1 .. Pfx'Length + 2); + begin + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 2) := ' '; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); + end Disp_Sub_Block; + + begin + Index := 0; + Get_Tree_Child (Blk, Index, Child); + while Child /= null loop + Get_Tree_Child (Blk, Index, Child2); + + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Disp_Header (Nctxt, False); + Disp_Sub_Block (Nblk, Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + Length : Ghdl_Index_Type; + Old_Child2 : Ghdl_Rti_Access; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + Disp_Header (Nctxt, Length > 1); + Old_Child2 := Child2; + if Length > 1 then + Child2 := Child; + end if; + for I in 1 .. Length loop + Disp_Sub_Block (Nblk, Nctxt); + if I /= Length then + Nctxt.Base := Nctxt.Base + Nblk.Size; + if I = Length - 1 then + Child2 := Old_Child2; + end if; + Disp_Header (Nctxt); + end if; + end loop; + Child2 := Old_Child2; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : constant Ghdl_Rtin_Block_Acc := + To_Ghdl_Rtin_Block_Acc (Child); + Nctxt : Rti_Context; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Disp_Header (Nctxt); + if Nctxt.Base /= Null_Address then + Disp_Sub_Block (Nblk, Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + declare + Inst : Ghdl_Rtin_Instance_Acc; + Sub_Ctxt : Rti_Context; + Sub_Blk : Ghdl_Rtin_Block_Acc; + Npfx : String (1 .. Pfx'Length + 4); + Comp : Ghdl_Rtin_Component_Acc; + Ch : Ghdl_Rti_Access; + begin + Disp_Header (Ctxt); + Inst := To_Ghdl_Rtin_Instance_Acc (Child); + Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); + Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); + if Inst.Instance.Kind = Ghdl_Rtik_Component + and then Disp_Tree_Flag >= Disp_Tree_Port + then + -- Disp generics and ports of the component. + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + for I in 1 .. Comp.Nbr_Child loop + Ch := Comp.Children (I - 1); + if Ch.Kind = Ghdl_Rtik_Port then + -- Disp only port (and not generics). + Put (Pfx); + if Child2 = null then + Put (" "); + else + Put ("| "); + end if; + if I = Comp.Nbr_Child and then Sub_Blk = null then + Put ("`-"); + else + Put ("+-"); + end if; + Disp_Tree_Child (Ch, Sub_Ctxt); + New_Line; + end if; + end loop; + end if; + if Sub_Blk /= null then + Npfx (1 .. Pfx'Length) := Pfx; + if Child2 = null then + Npfx (Pfx'Length + 1) := ' '; + else + Npfx (Pfx'Length + 1) := '|'; + end if; + Npfx (Pfx'Length + 2) := ' '; + Npfx (Pfx'Length + 3) := '`'; + Npfx (Pfx'Length + 4) := '-'; + Put (Npfx); + Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); + New_Line; + Npfx (Pfx'Length + 3) := ' '; + Npfx (Pfx'Length + 4) := ' '; + Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); + end if; + end; + when others => + Disp_Header (Ctxt); + end case; + + Child := Child2; + end loop; + end Disp_Tree_Block1; + + procedure Disp_Tree_Block + (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + is + begin + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + declare + Npfx : String (1 .. Pfx'Length + 2); + Nctxt : Rti_Context; + begin + -- The entity. + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); + -- Then the architecture. + Put (Pfx); + Put ("`-"); + Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); + New_Line; + Npfx (1 .. Pfx'Length) := Pfx; + Npfx (Pfx'Length + 1) := ' '; + Npfx (Pfx'Length + 2) := ' '; + Disp_Tree_Block1 (Blk, Ctxt, Npfx); + end; + when Ghdl_Rtik_Package_Body => + Disp_Tree_Block1 + (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); + when others => + Disp_Tree_Block1 (Blk, Ctxt, Pfx); + end case; + end Disp_Tree_Block; + + procedure Disp_Hierarchy + is + Ctxt : Rti_Context; + Parent : Ghdl_Rtin_Block_Acc; + Child : Ghdl_Rti_Access; + begin + if Disp_Tree_Flag = Disp_Tree_None then + return; + end if; + + Ctxt := Get_Top_Context; + Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + + Disp_Tree_Child (Parent.Parent, Ctxt); + New_Line; + Disp_Tree_Block (Parent, Ctxt, ""); + + for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop + Child := Ghdl_Rti_Top.Children (I - 1); + Ctxt := (Base => Null_Address, + Block => Child); + Disp_Tree_Child (Child, Ctxt); + New_Line; + Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); + end loop; + end Disp_Hierarchy; + + function Disp_Tree_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then + if Opt'Length = 11 then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=port" then + Disp_Tree_Flag := Disp_Tree_Port; + elsif Opt (12 .. Opt'Last) = "=proc" then + Disp_Tree_Flag := Disp_Tree_Proc; + elsif Opt (12 .. Opt'Last) = "=inst" then + Disp_Tree_Flag := Disp_Tree_Inst; + elsif Opt (12 .. Opt'Last) = "=none" then + Disp_Tree_Flag := Disp_Tree_None; + else + Error ("bad argument for --disp-tree option, try --help"); + end if; + return True; + else + return False; + end if; + end Disp_Tree_Option; + + procedure Disp_Tree_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --disp-tree[=KIND] disp the design hierarchy after elaboration"); + P (" KIND is inst, proc, port (default)"); + end Disp_Tree_Help; + + Disp_Tree_Hooks : aliased constant Hooks_Type := + (Option => Disp_Tree_Option'Access, + Help => Disp_Tree_Help'Access, + Init => null, + Start => Disp_Hierarchy'Access, + Finish => null); + + procedure Register is + begin + Register_Hooks (Disp_Tree_Hooks'Access); + end Register; + +end Grt.Disp_Tree; diff --git a/src/translate/grt/grt-disp_tree.ads b/src/translate/grt/grt-disp_tree.ads new file mode 100644 index 0000000..e3bc983 --- /dev/null +++ b/src/translate/grt/grt-disp_tree.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- 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. +package Grt.Disp_Tree is + procedure Register; +end Grt.Disp_Tree; diff --git a/src/translate/grt/grt-errors.adb b/src/translate/grt/grt-errors.adb new file mode 100644 index 0000000..eddea38 --- /dev/null +++ b/src/translate/grt/grt-errors.adb @@ -0,0 +1,253 @@ +-- GHDL Run Time (GRT) - Error handling. +-- 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.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Options; use Grt.Options; +with Grt.Hooks; use Grt.Hooks; + +package body Grt.Errors is + -- Called in case of premature exit. + -- CODE is 0 for success, 1 for failure. + procedure Ghdl_Exit (Code : Integer); + pragma No_Return (Ghdl_Exit); + + procedure Ghdl_Exit (Code : Integer) + is + procedure C_Exit (Status : Integer); + pragma Import (C, C_Exit, "exit"); + pragma No_Return (C_Exit); + begin + C_Exit (Code); + end Ghdl_Exit; + + procedure Maybe_Return_Via_Longjump (Val : Integer); + pragma Import (C, Maybe_Return_Via_Longjump, + "__ghdl_maybe_return_via_longjump"); + + procedure Exit_Simulation is + begin + Maybe_Return_Via_Longjump (-2); + Internal_Error ("exit_simulation"); + end Exit_Simulation; + + procedure Fatal_Error is + begin + if Error_Hook /= null then + -- Call the hook, but avoid infinite loop by reseting it. + declare + Current_Hook : constant Proc_Hook_Type := Error_Hook; + begin + Error_Hook := null; + Current_Hook.all; + end; + end if; + Maybe_Return_Via_Longjump (-1); + if Expect_Failure then + Ghdl_Exit (0); + else + Ghdl_Exit (1); + end if; + end Fatal_Error; + + procedure Put_Err (Str : String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (Str : Ghdl_C_String) is + begin + Put (stderr, Str); + end Put_Err; + + procedure Put_Err (N : Integer) is + begin + Put_I32 (stderr, Ghdl_I32 (N)); + end Put_Err; + + procedure Newline_Err is + begin + New_Line (stderr); + end Newline_Err; + +-- procedure Put_Err (Str : Ghdl_Str_Len_Type) +-- is +-- S : String (1 .. 3); +-- begin +-- if Str.Str = null then +-- S (1) := '''; +-- S (2) := Character'Val (Str.Len); +-- S (3) := '''; +-- Put_Err (S); +-- else +-- Put_Err (Str.Str (1 .. Str.Len)); +-- end if; +-- end Put_Err; + + procedure Report_H (Str : String := "") is + begin + Put_Err (Str); + end Report_H; + + procedure Report_C (Str : String) is + begin + Put_Err (Str); + end Report_C; + + procedure Report_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + Put_Err (Str (1 .. Len)); + end Report_C; + + procedure Report_C (N : Integer) + renames Put_Err; + + procedure Report_Now_C is + begin + Put_Time (stderr, Grt.Types.Current_Time); + end Report_Now_C; + + procedure Report_E (Str : String) is + begin + Put_Err (Str); + Newline_Err; + end Report_E; + + procedure Report_E (Str : Std_String_Ptr) + is + subtype Ada_Str is String (1 .. Natural (Str.Bounds.Dim_1.Length)); + begin + if Ada_Str'Length > 0 then + Put_Err (Ada_Str (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1))); + end if; + Newline_Err; + end Report_E; + + procedure Error_H is + begin + Put_Err (Progname); + Put_Err (":error: "); + end Error_H; + + Cont : Boolean := False; + + procedure Error_C (Str : String) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str); + end Error_C; + + procedure Error_C (Str : Ghdl_C_String) + is + Len : constant Natural := strlen (Str); + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (Str (1 .. Len)); + end Error_C; + + procedure Error_C (N : Integer) is + begin + if not Cont then + Error_H; + Cont := True; + end if; + Put_Err (N); + end Error_C; + +-- procedure Error_C (Inst : Ghdl_Instance_Name_Acc) +-- is +-- begin +-- if not Cont then +-- Error_H; +-- Cont := True; +-- end if; +-- if Inst.Parent /= null then +-- Error_C (Inst.Parent); +-- Put_Err ("."); +-- end if; +-- case Inst.Kind is +-- when Ghdl_Name_Architecture => +-- Put_Err ("("); +-- Put_Err (Inst.Name.all); +-- Put_Err (")"); +-- when others => +-- if Inst.Name /= null then +-- Put_Err (Inst.Name.all); +-- end if; +-- end case; +-- end Error_C; + + procedure Error_E (Str : String := "") is + begin + Put_Err (Str); + Newline_Err; + Cont := False; + Fatal_Error; + end Error_E; + + procedure Error_C_Std (Str : Std_String_Uncons) + is + subtype Str_Subtype is String (1 .. Str'Length); + begin + Error_C (Str_Subtype (Str)); + end Error_C_Std; + + procedure Error (Str : String) is + begin + Error_H; + Put_Err (Str); + Newline_Err; + Fatal_Error; + end Error; + + procedure Info (Str : String) is + begin + Put_Err (Progname); + Put_Err (":info: "); + Put_Err (Str); + Newline_Err; + end Info; + + procedure Internal_Error (Msg : String) is + begin + Put_Err (Progname); + Put_Err (":internal error: "); + Put_Err (Msg); + Newline_Err; + Fatal_Error; + end Internal_Error; + + procedure Grt_Overflow_Error is + begin + Error ("overflow detected"); + end Grt_Overflow_Error; +end Grt.Errors; diff --git a/src/translate/grt/grt-errors.ads b/src/translate/grt/grt-errors.ads new file mode 100644 index 0000000..c797a71 --- /dev/null +++ b/src/translate/grt/grt-errors.ads @@ -0,0 +1,84 @@ +-- GHDL Run Time (GRT) - Error handling. +-- 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.Types; use Grt.Types; +with Grt.Hooks; + +package Grt.Errors is + pragma Preelaborate (Grt.Errors); + + -- Multi-call error procedure. + -- Start and continue with Error_C, finish by an Error_E. + procedure Error_C (Str : String); + procedure Error_C (N : Integer); + procedure Error_C (Str : Ghdl_C_String); + procedure Error_C_Std (Str : Std_String_Uncons); + --procedure Error_C (Inst : Ghdl_Instance_Name_Acc); + procedure Error_E (Str : String := ""); + -- procedure Error_E_Std (Str : Std_String_Uncons); + pragma No_Return (Error_E); + + -- Multi-call report procedure. Do not exit at end. + procedure Report_H (Str : String := ""); + procedure Report_C (Str : Ghdl_C_String); + procedure Report_C (Str : String); + procedure Report_C (N : Integer); + procedure Report_Now_C; + procedure Report_E (Str : String); + procedure Report_E (Str : Std_String_Ptr); + + -- Complete error message. + procedure Error (Str : String); + + -- Internal error. The message must contain the subprogram name which + -- has called this procedure. + procedure Internal_Error (Msg : String); + pragma No_Return (Internal_Error); + + -- Display a message which is not an error. + procedure Info (Str : String); + + -- Display an error message for an overflow. + procedure Grt_Overflow_Error; + + -- Called at end of error message. Central point for failures. + procedure Fatal_Error; + pragma No_Return (Fatal_Error); + pragma Export (C, Fatal_Error, "__ghdl_fatal"); + + Exit_Status : Integer := 0; + procedure Exit_Simulation; + + -- Hook called in case of error. + Error_Hook : Grt.Hooks.Proc_Hook_Type := null; + + -- If true, an error is expected and the exit status is inverted. + Expect_Failure : Boolean := False; + +private + pragma Export (C, Grt_Overflow_Error, "grt_overflow_error"); + + pragma No_Return (Error); +end Grt.Errors; + diff --git a/src/translate/grt/grt-files.adb b/src/translate/grt/grt-files.adb new file mode 100644 index 0000000..30d51cf --- /dev/null +++ b/src/translate/grt/grt-files.adb @@ -0,0 +1,452 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- 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; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Table; +with System; use System; +pragma Elaborate_All (Grt.Table); + +package body Grt.Files is + subtype C_Files is Grt.Stdio.FILEs; + + Auto_Flush : constant Boolean := False; + + type File_Entry_Type is record + Stream : C_Files; + Signature : Ghdl_C_String; + Is_Text : Boolean; + Is_Alive : Boolean; + end record; + + package Files_Table is new Grt.Table + (Table_Component_Type => File_Entry_Type, + Table_Index_Type => Ghdl_File_Index, + Table_Low_Bound => 1, + Table_Initial => 2); + + function Get_File (Index : Ghdl_File_Index) return C_Files + is + begin + if Index not in Files_Table.First .. Files_Table.Last then + Internal_Error ("get_file: bad file index"); + end if; + return Files_Table.Table (Index).Stream; + end Get_File; + + procedure Check_File_Mode (Index : Ghdl_File_Index; Is_Text : Boolean) + is + begin + if Files_Table.Table (Index).Is_Text /= Is_Text then + Internal_Error ("check_file_mode: bad file mode"); + end if; + end Check_File_Mode; + + function Create_File (Is_Text : Boolean; Sig : Ghdl_C_String) + return Ghdl_File_Index is + begin + Files_Table.Append ((Stream => NULL_Stream, + Signature => Sig, + Is_Text => Is_Text, + Is_Alive => True)); + return Files_Table.Last; + end Create_File; + + procedure Destroy_File (Is_Text : Boolean; Index : Ghdl_File_Index) is + begin + if Get_File (Index) /= NULL_Stream then + Internal_Error ("destroy_file"); + end if; + Check_File_Mode (Index, Is_Text); + Files_Table.Table (Index).Is_Alive := False; + if Index = Files_Table.Last then + while Files_Table.Last >= Files_Table.First + and then Files_Table.Table (Files_Table.Last).Is_Alive = False + loop + Files_Table.Decrement_Last; + end loop; + end if; + end Destroy_File; + + procedure File_Error (File : Ghdl_File_Index) + is + pragma Unreferenced (File); + begin + Internal_Error ("file: IO error"); + end File_Error; + + function Ghdl_Text_File_Elaborate return Ghdl_File_Index is + begin + return Create_File (True, null); + end Ghdl_Text_File_Elaborate; + + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index + is + begin + return Create_File (False, Sig); + end Ghdl_File_Elaborate; + + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (True, File); + end Ghdl_Text_File_Finalize; + + procedure Ghdl_File_Finalize (File : Ghdl_File_Index) is + begin + Destroy_File (False, File); + end Ghdl_File_Finalize; + + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean + is + Stream : C_Files; + C : int; + begin + Stream := Get_File (File); + if feof (Stream) /= 0 then + return True; + end if; + C := fgetc (Stream); + if C < 0 then + return True; + end if; + if ungetc (C, Stream) /= C then + Error ("internal error: ungetc"); + end if; + return False; + end Ghdl_File_Endfile; + + Sig_Header : constant String := "#GHDL-BINARY-FILE-0.0" & Nl; + + function File_Open (File : Ghdl_File_Index; + Mode : Ghdl_I32; + Str : Std_String_Ptr) + return Ghdl_I32 + is + Name : String (1 .. Integer (Str.Bounds.Dim_1.Length) + 1); + Str_Mode : String (1 .. 3); + F : C_Files; + Sig : Ghdl_C_String; + Sig_Len : Natural; + begin + F := Get_File (File); + + if F /= NULL_Stream then + -- File was already open. + return Status_Error; + end if; + + -- Copy file name and convert it to a C string (NUL terminated). + for I in 1 .. Str.Bounds.Dim_1.Length loop + Name (Natural (I)) := Str.Base (I - 1); + end loop; + Name (Name'Last) := NUL; + + if Name = "STD_INPUT" & NUL then + if Mode /= Read_Mode then + return Mode_Error; + end if; + F := stdin; + elsif Name = "STD_OUTPUT" & NUL then + if Mode /= Write_Mode then + return Mode_Error; + end if; + F := stdout; + else + case Mode is + when Read_Mode => + Str_Mode (1) := 'r'; + when Write_Mode => + Str_Mode (1) := 'w'; + when Append_Mode => + Str_Mode (1) := 'a'; + when others => + -- Bad mode, cannot happen. + Internal_Error ("file_open: bad open mode"); + end case; + if Files_Table.Table (File).Is_Text then + Str_Mode (2) := NUL; + else + Str_Mode (2) := 'b'; + Str_Mode (3) := NUL; + end if; + F := fopen (Name'Address, Str_Mode'Address); + if F = NULL_Stream then + return Name_Error; + end if; + end if; + Sig := Files_Table.Table (File).Signature; + if Sig /= null then + Sig_Len := strlen (Sig); + case Mode is + when Write_Mode => + if fwrite (Sig_Header'Address, 1, Sig_Header'Length, F) + /= Sig_Header'Length + then + File_Error (File); + end if; + if fwrite (Sig (1)'Address, 1, size_t (Sig_Len), F) + /= size_t (Sig_Len) + then + File_Error (File); + end if; + when Read_Mode => + declare + Hdr : String (1 .. Sig_Header'Length); + Sig_Buf : String (1 .. Sig_Len); + begin + if fread (Hdr'Address, 1, Hdr'Length, F) /= Hdr'Length then + File_Error (File); + end if; + if Hdr /= Sig_Header then + File_Error (File); + end if; + if fread (Sig_Buf'Address, 1, Sig_Buf'Length, F) + /= Sig_Buf'Length + then + File_Error (File); + end if; + if Sig_Buf /= Sig (1 .. Sig_Len) then + File_Error (File); + end if; + end; + when Append_Mode => + null; + when others => + null; + end case; + end if; + Files_Table.Table (File).Stream := F; + return Open_Ok; + end File_Open; + + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, True); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open text file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_Text_File_Open; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + is + Res : Ghdl_I32; + begin + Check_File_Mode (File, False); + + Res := File_Open (File, Mode, Str); + + if Res /= Open_Ok then + Error_C ("open: cannot open file "); + Error_C_Std (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1)); + Error_E; + end if; + end Ghdl_File_Open; + + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, True); + return File_Open (File, Mode, Str); + end Ghdl_Text_File_Open_Status; + + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32 + is + begin + Check_File_Mode (File, False); + return File_Open (File, Mode, Str); + end Ghdl_File_Open_Status; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr) + is + Res : C_Files; + R : size_t; + R1 : int; + pragma Unreferenced (R, R1); + begin + Res := Get_File (File); + Check_File_Mode (File, True); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (Str.Base (0)'Address, + size_t (Str.Bounds.Dim_1.Length), 1, Res); + -- FIXME: check r + -- Write '\n'. + R1 := fputc (Character'Pos (Nl), Res); + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Text_Write; + + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fwrite (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("write_scalar failed"); + end if; + if Auto_Flush then + fflush (Res); + end if; + end Ghdl_Write_Scalar; + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type) + is + Res : C_Files; + R : size_t; + begin + Res := Get_File (File); + Check_File_Mode (File, False); + if Res = NULL_Stream then + Error ("write to a non-opened file"); + end if; + -- FIXME: check mode. + R := fread (System.Address (Ptr), size_t (Length), 1, Res); + if R /= 1 then + Error ("read_scalar failed"); + end if; + end Ghdl_Read_Scalar; + + function Ghdl_Text_Read_Length (File : Ghdl_File_Index; + Str : Std_String_Ptr) + return Std_Integer + is + Stream : C_Files; + C : int; + Len : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := Str.Bounds.Dim_1.Length; + -- Read until EOL (or EOF). + -- Store as much as possible. + for I in Ghdl_Index_Type loop + C := fgetc (Stream); + if C < 0 then + Error ("read: end of file reached"); + return Std_Integer (I); + end if; + if I < Len then + Str.Base (I) := Character'Val (C); + end if; + -- End of line is '\n' or LF or character # 10. + if C = 10 then + return Std_Integer (I + 1); + end if; + end loop; + return 0; + end Ghdl_Text_Read_Length; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr) + is + Stream : C_Files; + Len : int; + Idx : Ghdl_Index_Type; + begin + Stream := Get_File (File); + Check_File_Mode (File, True); + Len := int (Str.Bounds.Dim_1.Length); + if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then + Internal_Error ("ghdl_untruncated_text_read: end of file"); + end if; + -- Compute the length. + for I in Ghdl_Index_Type loop + if Str.Base (I) = NUL then + Idx := I; + exit; + end if; + end loop; + Res.Len := Std_Integer (Idx); + end Ghdl_Untruncated_Text_Read; + + procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean) + is + Stream : C_Files; + begin + Stream := Get_File (File); + Check_File_Mode (File, Is_Text); + -- LRM 3.4.1 File Operations + -- If F is not associated with an external file, then FILE_CLOSE has + -- no effect. + if Stream = NULL_Stream then + return; + end if; + if fclose (Stream) /= 0 then + Internal_Error ("file_close: fclose error"); + end if; + Files_Table.Table (File).Stream := NULL_Stream; + end File_Close; + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, True); + end Ghdl_Text_File_Close; + + procedure Ghdl_File_Close (File : Ghdl_File_Index) is + begin + File_Close (File, False); + end Ghdl_File_Close; + + procedure Ghdl_File_Flush (File : Ghdl_File_Index) + is + Stream : C_Files; + begin + Stream := Get_File (File); + if Stream = NULL_Stream then + return; + end if; + fflush (Stream); + end Ghdl_File_Flush; +end Grt.Files; + diff --git a/src/translate/grt/grt-files.ads b/src/translate/grt/grt-files.ads new file mode 100644 index 0000000..14f9984 --- /dev/null +++ b/src/translate/grt/grt-files.ads @@ -0,0 +1,123 @@ +-- GHDL Run Time (GRT) - VHDL files subprograms. +-- 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.Types; use Grt.Types; +with Interfaces; + +package Grt.Files is + type Ghdl_File_Index is new Interfaces.Integer_32; + + -- File open mode. + Read_Mode : constant Ghdl_I32 := 0; + Write_Mode : constant Ghdl_I32 := 1; + Append_Mode : constant Ghdl_I32 := 2; + + -- file_open_status. + Open_Ok : constant Ghdl_I32 := 0; + Status_Error : constant Ghdl_I32 := 1; + Name_Error : constant Ghdl_I32 := 2; + Mode_Error : constant Ghdl_I32 := 3; + + -- General files. + function Ghdl_File_Endfile (File : Ghdl_File_Index) return Boolean; + + -- Elaboration. + function Ghdl_Text_File_Elaborate return Ghdl_File_Index; + function Ghdl_File_Elaborate (Sig : Ghdl_C_String) return Ghdl_File_Index; + + -- Finalization. + procedure Ghdl_Text_File_Finalize (File : Ghdl_File_Index); + procedure Ghdl_File_Finalize (File : Ghdl_File_Index); + + -- Subprograms. + procedure Ghdl_Text_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_Text_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_File_Open + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr); + function Ghdl_File_Open_Status + (File : Ghdl_File_Index; Mode : Ghdl_I32; Str : Std_String_Ptr) + return Ghdl_I32; + + procedure Ghdl_Text_Write (File : Ghdl_File_Index; Str : Std_String_Ptr); + procedure Ghdl_Write_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + procedure Ghdl_Read_Scalar (File : Ghdl_File_Index; + Ptr : Ghdl_Ptr; + Length : Ghdl_Index_Type); + + function Ghdl_Text_Read_Length + (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer; + + type Ghdl_Untruncated_Text_Read_Result is record + Len : Std_Integer; + end record; + + type Ghdl_Untruncated_Text_Read_Result_Acc is + access Ghdl_Untruncated_Text_Read_Result; + + procedure Ghdl_Untruncated_Text_Read + (Res : Ghdl_Untruncated_Text_Read_Result_Acc; + File : Ghdl_File_Index; + Str : Std_String_Ptr); + + procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); + procedure Ghdl_File_Close (File : Ghdl_File_Index); + + procedure Ghdl_File_Flush (File : Ghdl_File_Index); +private + pragma Export (Ada, Ghdl_File_Endfile, "__ghdl_file_endfile"); + + pragma Export (C, Ghdl_Text_File_Elaborate, "__ghdl_text_file_elaborate"); + pragma Export (C, Ghdl_File_Elaborate, "__ghdl_file_elaborate"); + + pragma Export (C, Ghdl_Text_File_Finalize, "__ghdl_text_file_finalize"); + pragma Export (C, Ghdl_File_Finalize, "__ghdl_file_finalize"); + + pragma Export (C, Ghdl_Text_File_Open, "__ghdl_text_file_open"); + pragma Export (C, Ghdl_Text_File_Open_Status, + "__ghdl_text_file_open_status"); + + pragma Export (C, Ghdl_File_Open, "__ghdl_file_open"); + pragma Export (C, Ghdl_File_Open_Status, "__ghdl_file_open_status"); + + pragma Export (C, Ghdl_Text_Write, "__ghdl_text_write"); + pragma Export (C, Ghdl_Write_Scalar, "__ghdl_write_scalar"); + + pragma Export (C, Ghdl_Read_Scalar, "__ghdl_read_scalar"); + + pragma Export (C, Ghdl_Text_Read_Length, "__ghdl_text_read_length"); + pragma Export (C, Ghdl_Untruncated_Text_Read, + "std__textio__untruncated_text_read"); + + pragma Export (C, Ghdl_Text_File_Close, "__ghdl_text_file_close"); + pragma Export (C, Ghdl_File_Close, "__ghdl_file_close"); + + pragma Export (C, Ghdl_File_Flush, "__ghdl_file_flush"); +end Grt.Files; diff --git a/src/translate/grt/grt-hooks.adb b/src/translate/grt/grt-hooks.adb new file mode 100644 index 0000000..6a77aaf --- /dev/null +++ b/src/translate/grt/grt-hooks.adb @@ -0,0 +1,161 @@ +-- GHDL Run Time (GRT) - Hooks. +-- 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. + +package body Grt.Hooks is + type Hooks_Cell; + type Hooks_Cell_Acc is access Hooks_Cell; + type Hooks_Cell is record + Hooks : Hooks_Acc; + Next : Hooks_Cell_Acc; + end record; + + First_Hooks : Hooks_Cell_Acc := null; + Last_Hooks : Hooks_Cell_Acc := null; + + procedure Register_Hooks (Hooks : Hooks_Acc) + is + Cell : Hooks_Cell_Acc; + begin + Cell := new Hooks_Cell'(Hooks => Hooks, + Next => null); + if Last_Hooks = null then + First_Hooks := Cell; + else + Last_Hooks.Next := Cell; + end if; + Last_Hooks := Cell; + end Register_Hooks; + + type Hook_Cell; + type Hook_Cell_Acc is access Hook_Cell; + type Hook_Cell is record + Hook : Proc_Hook_Type; + Next : Hook_Cell_Acc; + end record; + + -- Chain of cycle hooks. + Cycle_Hook : Hook_Cell_Acc := null; + Last_Cycle_Hook : Hook_Cell_Acc := null; + + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type) + is + Cell : Hook_Cell_Acc; + begin + Cell := new Hook_Cell'(Hook => Proc, + Next => null); + if Cycle_Hook = null then + Cycle_Hook := Cell; + else + Last_Cycle_Hook.Next := Cell; + end if; + Last_Cycle_Hook := Cell; + end Register_Cycle_Hook; + + procedure Call_Cycle_Hooks + is + Cell : Hook_Cell_Acc; + begin + Cell := Cycle_Hook; + while Cell /= null loop + Cell.Hook.all; + Cell := Cell.Next; + end loop; + end Call_Cycle_Hooks; + + function Call_Option_Hooks (Opt : String) return Boolean + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Option /= null + and then Cell.Hooks.Option.all (Opt) + then + return True; + end if; + Cell := Cell.Next; + end loop; + return False; + end Call_Option_Hooks; + + procedure Call_Help_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Help /= null then + Cell.Hooks.Help.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Help_Hooks; + + procedure Call_Init_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Init /= null then + Cell.Hooks.Init.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Init_Hooks; + + procedure Call_Start_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Start /= null then + Cell.Hooks.Start.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Start_Hooks; + + procedure Call_Finish_Hooks + is + Cell : Hooks_Cell_Acc; + begin + Cell := First_Hooks; + while Cell /= null loop + if Cell.Hooks.Finish /= null then + Cell.Hooks.Finish.all; + end if; + Cell := Cell.Next; + end loop; + end Call_Finish_Hooks; + + procedure Proc_Hook_Nil is + begin + null; + end Proc_Hook_Nil; +end Grt.Hooks; + + diff --git a/src/translate/grt/grt-hooks.ads b/src/translate/grt/grt-hooks.ads new file mode 100644 index 0000000..20846c7 --- /dev/null +++ b/src/translate/grt/grt-hooks.ads @@ -0,0 +1,70 @@ +-- GHDL Run Time (GRT) - Hooks. +-- 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. +package Grt.Hooks is + pragma Preelaborate (Grt.Hooks); + + type Option_Hook_Type is access function (Opt : String) return Boolean; + type Proc_Hook_Type is access procedure; + + type Hooks_Type is record + -- Called for every unknown command line argument. + -- Return TRUE if handled. + Option : Option_Hook_Type; + + -- Display command line help. + Help : Proc_Hook_Type; + + -- Called at initialization (after decoding options). + Init : Proc_Hook_Type; + + -- Called just after elaboration. + Start : Proc_Hook_Type; + + -- Called at the end of execution. + Finish : Proc_Hook_Type; + end record; + + type Hooks_Acc is access constant Hooks_Type; + + -- Registers hook. + procedure Register_Hooks (Hooks : Hooks_Acc); + + -- Register an hook which will call PROC after every non-delta cycles. + procedure Register_Cycle_Hook (Proc : Proc_Hook_Type); + + -- Call hooks. + function Call_Option_Hooks (Opt : String) return Boolean; + procedure Call_Help_Hooks; + procedure Call_Init_Hooks; + procedure Call_Start_Hooks; + procedure Call_Finish_Hooks; + + -- Call non-delta cycles hooks. + procedure Call_Cycle_Hooks; + pragma Inline_Always (Call_Cycle_Hooks); + + -- Nil procedure. + procedure Proc_Hook_Nil; +end Grt.Hooks; diff --git a/src/translate/grt/grt-images.adb b/src/translate/grt/grt-images.adb new file mode 100644 index 0000000..342c98f --- /dev/null +++ b/src/translate/grt/grt-images.adb @@ -0,0 +1,387 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- 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 System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Conversion; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Processes; use Grt.Processes; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Errors; use Grt.Errors; + +package body Grt.Images is + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type) + is + begin + Res.Bounds := To_Std_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Res.Bounds.Dim_1 := (Left => 1, + Right => Std_Integer (Len), + Dir => Dir_To, + Length => Len); + end Set_String_Bounds; + + procedure Return_String (Res : Std_String_Ptr; Str : String) + is + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length)); + for I in 0 .. Str'Length - 1 loop + Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I); + end loop; + Set_String_Bounds (Res, Str'Length); + end Return_String; + + procedure Return_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + Return_String (Res, Str (1 .. strlen (Str))); + end Return_Enum; + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_Image_B1; + + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_Image_E8; + + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) + is + begin + Return_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_Image_E32; + + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + To_String (Str, First, Val); + Return_String (Res, Str (First .. Str'Last)); + end Ghdl_Image_I32; + + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 21); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P64; + + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + is + Str : String (1 .. 11); + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + To_String (Str, First, Val); + Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Image_P32; + + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + is + Str : String (1 .. 24); + P : Natural; + begin + To_String (Str, P, Val); + Return_String (Res, Str (1 .. P)); + end Ghdl_Image_F64; + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) + renames Ghdl_Image_I32; + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) + renames Ghdl_Image_F64; + + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32) + is + Str : String_Real_Digits; + P : Natural; + begin + To_String (Str, P, Val, Nbr_Digits); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Digits; + + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr) + is + C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1)); + Str : Grt.Vstrings.String_Real_Format; + P : Natural; + begin + for I in 1 .. C_Format'Last - 1 loop + C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1)); + end loop; + C_Format (C_Format'Last) := NUL; + + To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address)); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Format; + + subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4; + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Ghdl_BV_To_String (Res : Std_String_Ptr; + Val : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type; + Log_Base : Log_Base_Type) + is + Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base; + Pos : Ghdl_Index_Type; + V : Natural; + Sh : Natural range 0 .. 4; + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len)); + V := 0; + Sh := 0; + Pos := Res_Len - 1; + for I in reverse 1 .. Len loop + V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh); + Sh := Sh + 1; + if Sh = Natural (Log_Base) or else I = 1 then + Res.Base (Pos) := Hex_Chars (V); + Pos := Pos - 1; + Sh := 0; + V := 0; + end if; + end loop; + Set_String_Bounds (Res, Res_Len); + end Ghdl_BV_To_String; + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 3); + end Ghdl_BV_To_Ostring; + + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type) is + begin + Ghdl_BV_To_String (Res, Base, Len, 4); + end Ghdl_BV_To_Hstring; + + procedure To_String_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + if Str (1) = ''' then + Return_String (Res, Str (2 .. 2)); + else + Return_String (Res, Str (1 .. strlen (Str))); + end if; + end To_String_Enum; + + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_To_String_B1; + + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_To_String_E8; + + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_To_String_E32; + + procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is + begin + Return_String (Res, (1 => Val)); + end Ghdl_To_String_Char; + + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P32; + + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P64; + + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access) + is + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + Unit_Name := null; + for I in 1 .. Phys.Nbr loop + if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit) + then + Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1)); + exit; + end if; + end loop; + if Unit_Name = null then + Error ("no unit for to_string"); + end if; + Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Time_To_String_Unit; + + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_B1; + + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E8; + + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E32_Array_Base_Ptr := + To_Ghdl_E32_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E32; + +-- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) +-- is +-- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) +-- -- + exp_digits (4) -> 24. +-- Str : String (1 .. 25); + +-- procedure Snprintf_G (Str : System.Address; +-- Size : Integer; +-- Arg : Ghdl_F64); +-- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + +-- function strlen (Str : System.Address) return Integer; +-- pragma Import (C, strlen); +-- begin +-- Snprintf_G (Str'Address, Str'Length, Val); +-- Return_String (Res, Str (1 .. strlen (Str'Address))); +-- end Ghdl_Image_F64; + +end Grt.Images; diff --git a/src/translate/grt/grt-images.ads b/src/translate/grt/grt-images.ads new file mode 100644 index 0000000..cd89110 --- /dev/null +++ b/src/translate/grt/grt-images.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - 'image subprograms. +-- 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.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Images is + -- For all images procedures, the result is allocated on the secondary + -- stack. + + procedure Ghdl_Image_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_Image_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Image_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + + procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32); + procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); + procedure Ghdl_To_String_F64_Digits + (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32); + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr); + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_Char + (Res : Std_String_Ptr; Val : Std_Character); + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); + procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; + Base : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type); +private + pragma Export (Ada, Ghdl_Image_B1, "__ghdl_image_b1"); + pragma Export (C, Ghdl_Image_E8, "__ghdl_image_e8"); + pragma Export (C, Ghdl_Image_E32, "__ghdl_image_e32"); + pragma Export (C, Ghdl_Image_I32, "__ghdl_image_i32"); + pragma Export (C, Ghdl_Image_F64, "__ghdl_image_f64"); + pragma Export (C, Ghdl_Image_P64, "__ghdl_image_p64"); + pragma Export (C, Ghdl_Image_P32, "__ghdl_image_p32"); + + pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32"); + pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64"); + pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits"); + pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format"); + pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1"); + pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8"); + pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32"); + pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char"); + pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32"); + pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64"); + pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit"); + pragma Export (C, Ghdl_Array_Char_To_String_B1, + "__ghdl_array_char_to_string_b1"); + pragma Export (C, Ghdl_Array_Char_To_String_E8, + "__ghdl_array_char_to_string_e8"); + pragma Export (C, Ghdl_Array_Char_To_String_E32, + "__ghdl_array_char_to_string_e32"); + pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring"); + pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring"); +end Grt.Images; diff --git a/src/translate/grt/grt-lib.adb b/src/translate/grt/grt-lib.adb new file mode 100644 index 0000000..d2b095c --- /dev/null +++ b/src/translate/grt/grt-lib.adb @@ -0,0 +1,298 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- 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; +with Grt.Options; + +package body Grt.Lib is + --procedure Memcpy (Dst : Address; Src : Address; Size : Size_T); + --pragma Import (C, Memcpy); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type) + is + procedure Memmove + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + pragma Import (C, Memmove); + begin + Memmove (Dest, Src, Size); + end Ghdl_Memcpy; + + procedure Do_Report (Msg : String; + Str : Std_String_Ptr; + Default_Str : String; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + Level : constant Integer := Severity mod 256; + begin + Report_H; + Report_C (Loc.Filename); + Report_C (":"); + Report_C (Loc.Line); + Report_C (":"); + Report_C (Loc.Col); + Report_C (":@"); + Report_Now_C; + Report_C (":("); + Report_C (Msg); + Report_C (" "); + case Level is + when Note_Severity => + Report_C ("note"); + when Warning_Severity => + Report_C ("warning"); + when Error_Severity => + Report_C ("error"); + when Failure_Severity => + Report_C ("failure"); + when others => + Report_C ("???"); + end case; + Report_C ("): "); + if Str /= null then + Report_E (Str); + else + Report_E (Default_Str); + end if; + if Level >= Grt.Options.Severity_Level then + Error_C (Msg); + Error_E (" failed"); + end if; + end Do_Report; + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Assert_Failed; + + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) + is + use Grt.Options; + begin + if Ieee_Asserts = Disable_Asserts + or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0) + then + return; + else + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end if; + end Ghdl_Ieee_Assert_Failed; + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc); + end Ghdl_Psl_Assert_Failed; + + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover", Str, "sequence covered", Severity, Loc); + end Ghdl_Psl_Cover; + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + begin + Do_Report ("psl cover failure", + Str, "sequence not covered", Severity, Loc); + end Ghdl_Psl_Cover_Failed; + + procedure Ghdl_Report + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr) + is + begin + Do_Report ("report", Str, "Assertion violation", Severity, Loc); + end Ghdl_Report; + + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type) + is + begin + case Code is + when 1 => + Error_C ("missing return in function"); + when 2 => + Error_C ("block already configured"); + when 3 => + Error_C ("bad configuration"); + when others => + Error_C ("unknown error code "); + Error_C (Integer (Code)); + end case; + Error_C (" at "); + if Filename = null then + Error_C ("*unknown*"); + else + Error_C (Filename); + end if; + Error_C (":"); + Error_C (Integer(Line)); + Error_E (""); + end Ghdl_Program_Error; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32) + is + begin + Error_C ("bound check failure at "); + Error_C (Filename); + Error_C (":"); + Error_C (Integer (Line)); + Error_E (""); + end Ghdl_Bound_Check_Failed_L1; + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32 + is + pragma Suppress (Overflow_Check); + + R : Ghdl_I32; + Res : Ghdl_I32; + P : Ghdl_I32; + T : Ghdl_I64; + begin + if E < 0 then + Error ("negative exponent"); + end if; + Res := 1; + P := V; + R := E; + loop + if R mod 2 = 1 then + T := Ghdl_I64 (Res) * Ghdl_I64 (P); + Res := Ghdl_I32 (T); + if Ghdl_I64 (Res) /= T then + Error ("overflow in exponentiation"); + end if; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + end Ghdl_Integer_Exp; + + function C_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + pragma Import (C, C_Malloc, "malloc"); + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr is + begin + return C_Malloc (Size); + end Ghdl_Malloc; + + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr + is + procedure Memset (Ptr : Ghdl_Ptr; C : Integer; Size : Ghdl_Index_Type); + pragma Import (C, Memset); + + Res : Ghdl_Ptr; + begin + Res := C_Malloc (Size); + Memset (Res, 0, Size); + return Res; + end Ghdl_Malloc0; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr) + is + procedure C_Free (Ptr : Ghdl_Ptr); + pragma Import (C, C_Free, "free"); + begin + C_Free (Ptr); + end Ghdl_Deallocate; + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real + is + R : Ghdl_I32; + Res : Ghdl_Real; + P : Ghdl_Real; + begin + Res := 1.0; + P := X; + R := Exp; + if R >= 0 then + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + return Res; + else + R := -R; + loop + if R mod 2 = 1 then + Res := Res * P; + end if; + R := R / 2; + exit when R = 0; + P := P * P; + end loop; + if Res = 0.0 then + Error ("division per 0.0"); + return 0.0; + end if; + return 1.0 / Res; + end if; + end Ghdl_Real_Exp; + + function Ghdl_Get_Resolution_Limit return Std_Time is + begin + return 1; + end Ghdl_Get_Resolution_Limit; + + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is + begin + Report_H; + -- Report_C (Grt.Options.Progname); + Report_C ("simulation "); + if Stop then + Report_C ("stopped"); + else + Report_C ("finished"); + end if; + Report_C (" @"); + Report_Now_C; + if Has_Status then + Report_C (" with status "); + Report_C (Integer (Status)); + end if; + Report_E (""); + if Has_Status then + Exit_Status := Integer (Status); + end if; + Exit_Simulation; + end Ghdl_Control_Simulation; + +end Grt.Lib; diff --git a/src/translate/grt/grt-lib.ads b/src/translate/grt/grt-lib.ads new file mode 100644 index 0000000..4dac2c8 --- /dev/null +++ b/src/translate/grt/grt-lib.ads @@ -0,0 +1,127 @@ +-- GHDL Run Time (GRT) - misc subprograms. +-- 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.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Lib is + pragma Preelaborate (Grt.Lib); + + procedure Ghdl_Memcpy + (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); + + procedure Ghdl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; + Severity : Integer; + Loc : Ghdl_Location_Ptr); + + -- Called when a sequence is covered (in a cover directive) + procedure Ghdl_Psl_Cover + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Psl_Cover_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + procedure Ghdl_Report + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + + Note_Severity : constant Integer := 0; + Warning_Severity : constant Integer := 1; + Error_Severity : constant Integer := 2; + Failure_Severity : constant Integer := 3; + + procedure Ghdl_Bound_Check_Failed_L1 (Filename : Ghdl_C_String; + Line: Ghdl_I32); + + -- Program error has occured: + -- * configuration of an already configured block. + procedure Ghdl_Program_Error (Filename : Ghdl_C_String; + Line : Ghdl_I32; + Code : Ghdl_Index_Type); + + function Ghdl_Integer_Exp (V : Ghdl_I32; E : Ghdl_I32) + return Ghdl_I32; + + function Ghdl_Malloc (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + -- Allocate and clear SIZE bytes. + function Ghdl_Malloc0 (Size : Ghdl_Index_Type) return Ghdl_Ptr; + + procedure Ghdl_Deallocate (Ptr : Ghdl_Ptr); + + function Ghdl_Real_Exp (X : Ghdl_Real; Exp : Ghdl_I32) + return Ghdl_Real; + + type Ghdl_Std_Ulogic_Boolean_Array_Type is array (Ghdl_E8 range 0 .. 8) + of Ghdl_B1; + + Ghdl_Std_Ulogic_To_Boolean_Array : + constant Ghdl_Std_Ulogic_Boolean_Array_Type := (False, -- U + False, -- X + False, -- 0 + True, -- 1 + False, -- Z + False, -- W + False, -- L + True, -- H + False -- - + ); + + function Ghdl_Get_Resolution_Limit return Std_Time; + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer); +private + pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); + + pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed"); + pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed"); + pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed"); + pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover"); + pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed"); + pragma Export (C, Ghdl_Report, "__ghdl_report"); + + pragma Export (C, Ghdl_Bound_Check_Failed_L1, + "__ghdl_bound_check_failed_l1"); + pragma Export (C, Ghdl_Program_Error, "__ghdl_program_error"); + + pragma Export (C, Ghdl_Malloc, "__ghdl_malloc"); + pragma Export (C, Ghdl_Malloc0, "__ghdl_malloc0"); + pragma Export (C, Ghdl_Deallocate, "__ghdl_deallocate"); + + pragma Export (C, Ghdl_Integer_Exp, "__ghdl_integer_exp"); + pragma Export (C, Ghdl_Real_Exp, "__ghdl_real_exp"); + + pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array, + "__ghdl_std_ulogic_to_boolean_array"); + + pragma Export (C, Ghdl_Get_Resolution_Limit, + "__ghdl_get_resolution_limit"); + pragma Export (Ada, Ghdl_Control_Simulation, + "__ghdl_control_simulation"); +end Grt.Lib; diff --git a/src/translate/grt/grt-main.adb b/src/translate/grt/grt-main.adb new file mode 100644 index 0000000..116ea7b --- /dev/null +++ b/src/translate/grt/grt-main.adb @@ -0,0 +1,190 @@ +-- GHDL Run Time (GRT) - entry point. +-- 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.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; +with Grt.Stats; +with Grt.Hooks; +with Grt.Disp_Signals; +with Grt.Disp; +with Grt.Modules; + +-- The following packages are not referenced in this package. +-- These are subprograms called only from GHDL generated code. +-- They are with'ed in order to be present in the binary. +pragma Warnings (Off); +with Grt.Files; +with Grt.Types; +with Grt.Lib; +with Grt.Shadow_Ieee; +with Grt.Images; +with Grt.Values; +with Grt.Names; +pragma Warnings (On); + +package body Grt.Main is + procedure Ghdl_Elaborate; + pragma Import (C, Ghdl_Elaborate, "__ghdl_ELABORATE"); + + -- Wrapper around elaboration just to return 0. + function Ghdl_Elaborate_Wrapper return Integer is + begin + Ghdl_Elaborate; + return 0; + end Ghdl_Elaborate_Wrapper; + + procedure Disp_Stats_Hook (Code : Integer); + pragma Convention (C, Disp_Stats_Hook); + + procedure Disp_Stats_Hook (Code : Integer) + is + pragma Unreferenced (Code); + begin + Stats.End_Simulation; + Stats.Disp_Stats; + end Disp_Stats_Hook; + + procedure Check_Flag_String + is + Err : Boolean; + begin + -- The conditions may be statically known. + pragma Warnings (Off); + + Err := False; + if (Std_Integer'Size = 32 and Flag_String (3) /= 'i') + or else (Std_Integer'Size = 64 and Flag_String (3) /= 'I') + then + Err := True; + end if; + if (Std_Time'Size = 32 and Flag_String (4) /= 't') + or else (Std_Time'Size = 64 and Flag_String (4) /= 'T') + then + Err := True; + end if; + + pragma Warnings (On); + + if Err then + Grt.Errors.Error + ("GRT is not consistent with the flags used for your design"); + end if; + end Check_Flag_String; + + procedure Run + is + use Grt.Errors; + Stop : Boolean; + Status : Integer; + begin + -- Register modules. + -- They may insert hooks. + Grt.Modules.Register_Modules; + + -- If the time resolution is to be set by the user, select a default + -- resolution. Options may override it. + if Flag_String (5) = '?' then + Set_Time_Resolution ('n'); + end if; + + -- Decode options. + Grt.Options.Decode (Stop); + + -- Check coherency between GRT and GHDL generated code. + Check_Flag_String; + + -- Early stop (for options such as --help). + if Stop then + return; + end if; + + -- Internal initializations. + Grt.Stacks.Stack_Init; + + Grt.Hooks.Call_Init_Hooks; + + Grt.Processes.Init; + + Grt.Signals.Init; + + if Flag_Stats then + Stats.Start_Elaboration; + end if; + + -- Elaboration. Run through longjump to catch errors. + if Grt.Processes.Run_Through_Longjump (Ghdl_Elaborate_Wrapper'Access) < 0 + then + Grt.Errors.Error ("error during elaboration"); + return; + end if; + + if Flag_Stats then + Stats.Start_Order; + end if; + + Grt.Hooks.Call_Start_Hooks; + + if not Flag_No_Run then + 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; + + -- Do the simulation. + Status := Grt.Processes.Simulation; + end if; + + if Flag_Stats then + Disp_Stats_Hook (0); + end if; + + if Expect_Failure then + if Status >= 0 then + Expect_Failure := False; + Error ("error expected, but none occured"); + end if; + else + if Status < 0 then + Error ("simulation failed"); + end if; + end if; + end Run; + +end Grt.Main; diff --git a/src/translate/grt/grt-main.ads b/src/translate/grt/grt-main.ads new file mode 100644 index 0000000..4f78477 --- /dev/null +++ b/src/translate/grt/grt-main.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - entry point. +-- 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. + +package Grt.Main is + -- Elaborate and simulate the design. + procedure Run; +end Grt.Main; diff --git a/src/translate/grt/grt-modules.adb b/src/translate/grt/grt-modules.adb new file mode 100644 index 0000000..e5304f0 --- /dev/null +++ b/src/translate/grt/grt-modules.adb @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 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.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; +with Grt.Vcdz; +with Grt.Vpi; +with Grt.Waves; +with Grt.Vital_Annotate; +with Grt.Disp_Tree; +with Grt.Disp_Rti; + +package body Grt.Modules is + procedure Register_Modules is + begin + -- List of modules to be registered. + Grt.Disp_Tree.Register; + Grt.Vcd.Register; + Grt.Vcdz.Register; + Grt.Waves.Register; + Grt.Vpi.Register; + Grt.Vital_Annotate.Register; + Grt.Disp_Rti.Register; + end Register_Modules; +end Grt.Modules; diff --git a/src/translate/grt/grt-modules.ads b/src/translate/grt/grt-modules.ads new file mode 100644 index 0000000..23c7d6e --- /dev/null +++ b/src/translate/grt/grt-modules.ads @@ -0,0 +1,29 @@ +-- GHDL Run Time (GRT) - Modules. +-- Copyright (C) 2005 - 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. + +package Grt.Modules is + -- Register optional modules. + procedure Register_Modules; +end Grt.Modules; diff --git a/src/translate/grt/grt-names.adb b/src/translate/grt/grt-names.adb new file mode 100644 index 0000000..e7928f7 --- /dev/null +++ b/src/translate/grt/grt-names.adb @@ -0,0 +1,105 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- 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; +with Ada.Unchecked_Conversion; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Processes; use Grt.Processes; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; +with Grt.Vstrings; use Grt.Vstrings; + +package body Grt.Names is + function To_Str_String_Boundp is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Boundp); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => String_Ptr, Target => Std_String_Basep); + + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Std_String_Basep); + + procedure Get_Name (Res : Std_String_Ptr; + Ctxt : Rti_Context; + Name : Ghdl_Str_Len_Ptr; + Is_Path : Boolean) + is + procedure Memcpy (Dst : Address; Src : Address; Len : Integer); + pragma Import (C, Memcpy); + + Bounds : Std_String_Boundp; + Len : Natural; + + Rstr : Rstring; + R_Len : Natural; + begin + if Ctxt.Block /= null then + Prepend (Rstr, ':'); + Get_Path_Name (Rstr, Ctxt, ':', not Is_Path); + R_Len := Length (Rstr); + Len := R_Len + Name.Len; + else + Len := Name.Len; + end if; + + Bounds := To_Str_String_Boundp + (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Bounds.Dim_1.Left := 1; + Bounds.Dim_1.Right := Ghdl_I32 (Len); + Bounds.Dim_1.Dir := Dir_To; + Bounds.Dim_1.Length := Ghdl_Index_Type (Len); + Res.Bounds := Bounds; + if Ctxt.Block /= null then + Res.Base := To_Std_String_Basep + (Ghdl_Stack2_Allocate (Ghdl_Index_Type (Len))); + Memcpy (Res.Base (0)'Address, Get_Address (Rstr), R_Len); + Memcpy (Res.Base (Ghdl_Index_Type (R_Len))'Address, + Name.Str (1)'Address, + Name.Len); + Free (Rstr); + else + Res.Base := To_Std_String_Basep (Name.Str); + end if; + end Get_Name; + + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, True); + end Ghdl_Get_Path_Name; + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr) + is + begin + Get_Name (Res, (Base, Ctxt), Name, False); + end Ghdl_Get_Instance_Name; + +end Grt.Names; diff --git a/src/translate/grt/grt-names.ads b/src/translate/grt/grt-names.ads new file mode 100644 index 0000000..e0c2842 --- /dev/null +++ b/src/translate/grt/grt-names.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - 'name* subprograms. +-- 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 Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Names is + procedure Ghdl_Get_Path_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); + + procedure Ghdl_Get_Instance_Name (Res : Std_String_Ptr; + Ctxt : Ghdl_Rti_Access; + Base : Address; + Name : Ghdl_Str_Len_Ptr); +private + pragma Export (C, Ghdl_Get_Path_Name, "__ghdl_get_path_name"); + pragma Export (C, Ghdl_Get_Instance_Name, "__ghdl_get_instance_name"); +end Grt.Names; diff --git a/src/translate/grt/grt-options.adb b/src/translate/grt/grt-options.adb new file mode 100644 index 0000000..df1eb4e --- /dev/null +++ b/src/translate/grt/grt-options.adb @@ -0,0 +1,507 @@ +-- GHDL Run Time (GRT) - command line options. +-- 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 Interfaces; use Interfaces; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; +with Grt.Hooks; + +package body Grt.Options is + + Std_Standard_Time_Fs : Std_Time; + Std_Standard_Time_Ps : Std_Time; + Std_Standard_Time_Ns : Std_Time; + Std_Standard_Time_Us : Std_Time; + Std_Standard_Time_Ms : Std_Time; + Std_Standard_Time_Sec : Std_Time; + Std_Standard_Time_Min : Std_Time; + Std_Standard_Time_Hr : Std_Time; + pragma Export (C, Std_Standard_Time_Fs, "std__standard__time__BT__fs"); + pragma Weak_External (Std_Standard_Time_Fs); + pragma Export (C, Std_Standard_Time_Ps, "std__standard__time__BT__ps"); + pragma Weak_External (Std_Standard_Time_Ps); + pragma Export (C, Std_Standard_Time_Ns, "std__standard__time__BT__ns"); + pragma Weak_External (Std_Standard_Time_Ns); + pragma Export (C, Std_Standard_Time_Us, "std__standard__time__BT__us"); + pragma Weak_External (Std_Standard_Time_Us); + pragma Export (C, Std_Standard_Time_Ms, "std__standard__time__BT__ms"); + pragma Weak_External (Std_Standard_Time_Ms); + pragma Export (C, Std_Standard_Time_Sec, "std__standard__time__BT__sec"); + pragma Weak_External (Std_Standard_Time_Sec); + pragma Export (C, Std_Standard_Time_Min, "std__standard__time__BT__min"); + pragma Weak_External (Std_Standard_Time_Min); + pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr"); + pragma Weak_External (Std_Standard_Time_Hr); + + procedure Set_Time_Resolution (Res : Character) + is + begin + Std_Standard_Time_Hr := 0; + case Res is + when 'f' => + Std_Standard_Time_Fs := 1; + Std_Standard_Time_Ps := 1000; + Std_Standard_Time_Ns := 1000_000; + Std_Standard_Time_Us := 1000_000_000; + Std_Standard_Time_Ms := Std_Time'Last; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'p' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 1; + Std_Standard_Time_Ns := 1000; + Std_Standard_Time_Us := 1000_000; + Std_Standard_Time_Ms := 1000_000_000; + Std_Standard_Time_Sec := Std_Time'Last; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'n' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 1; + Std_Standard_Time_Us := 1000; + Std_Standard_Time_Ms := 1000_000; + Std_Standard_Time_Sec := 1000_000_000; + Std_Standard_Time_Min := Std_Time'Last; + Std_Standard_Time_Hr := Std_Time'Last; + when 'u' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 1; + Std_Standard_Time_Ms := 1000; + Std_Standard_Time_Sec := 1000_000; + Std_Standard_Time_Min := 60_000_000; + Std_Standard_Time_Hr := Std_Time'Last; + when 'm' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 1; + Std_Standard_Time_Sec := 1000; + Std_Standard_Time_Min := 60_000; + Std_Standard_Time_Hr := 3600_000; + when 's' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 1; + Std_Standard_Time_Min := 60; + Std_Standard_Time_Hr := 3600; + when 'M' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 1; + Std_Standard_Time_Hr := 60; + when 'h' => + Std_Standard_Time_Fs := 0; + Std_Standard_Time_Ps := 0; + Std_Standard_Time_Ns := 0; + Std_Standard_Time_Us := 0; + Std_Standard_Time_Ms := 0; + Std_Standard_Time_Sec := 0; + Std_Standard_Time_Min := 0; + Std_Standard_Time_Hr := 1; + when others => + Error ("bad time resolution"); + end case; + end Set_Time_Resolution; + + procedure Help + is + use Grt.Astdio; + procedure P (Str : String) renames Put_Line; + Prog_Name : Ghdl_C_String; + begin + if Argc > 0 then + Prog_Name := Argv (0); + Put ("Usage: "); + Put (Prog_Name (1 .. strlen (Prog_Name))); + Put (" [OPTIONS]"); + New_Line; + end if; + + P ("Options are:"); + P (" --help, -h disp this help"); + P (" --assert-level=LEVEL stop simulation if assert at LEVEL"); + P (" LEVEL is note,warning,error,failure,none"); + P (" --ieee-asserts=POLICY enable or disable asserts from IEEE"); + P (" POLICY is enable,disable,disable-at-0"); + P (" --stop-time=X stop the simulation at time X"); + 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; + P ("trace options:"); + P (" --disp-time disp time as simulation advances"); + P (" --trace-signals disp signals after each cycle"); + P (" --trace-processes disp process name before each cycle"); + P (" --stats display run-time statistics"); + P ("debug options:"); + P (" --disp-order disp signals order"); + P (" --disp-sources disp sources while displaying signals"); + P (" --disp-sig-types disp signal types"); + P (" --disp-signals-map disp map bw declared sigs and internal sigs"); + P (" --disp-signals-table disp internal signals"); + P (" --checks do internal checks after each process run"); + P (" --activity=LEVEL watch activity of LEVEL signals"); + P (" LEVEL is all, min (default) or none (unsafe)"); + end Help; + + -- Extract from STR a number. + -- First, all leading blanks are skipped. + -- Then, all next digits are eaten. + -- The position of the first non digit or one past the upper bound is + -- returned into POS. + -- If there is no digits, OK is set to false, else to true. + procedure Extract_Integer + (Str : String; + Ok : out Boolean; + Result : out Integer_64; + Pos : out Natural) + is + begin + Pos := Str'First; + -- Skip blanks. + while Pos <= Str'Last and then Str (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + Ok := False; + Result := 0; + loop + exit when Pos > Str'Last or else Str (Pos) not in '0' .. '9'; + Ok := True; + Result := Result * 10 + + (Character'Pos (Str (Pos)) - Character'Pos ('0')); + Pos := Pos + 1; + 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 + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status) + is + pragma Assert (Option'First = 1); + Len : constant Natural := Option'Last; + begin + Status := Decode_Option_Ok; + if Option = "--" then + Status := Decode_Option_Last; + elsif Option = "--help" or else Option = "-h" then + Help; + Status := Decode_Option_Help; + elsif Option = "--disp-time" then + Disp_Time := True; + elsif Option = "--trace-signals" then + Trace_Signals := True; + Disp_Time := True; + elsif Option = "--trace-processes" then + Trace_Processes := True; + Disp_Time := True; + elsif Option = "--disp-order" then + Disp_Signals_Order := True; + elsif Option = "--checks" then + Checks := True; + elsif Option = "--disp-sources" then + Disp_Sources := True; + elsif Option = "--disp-sig-types" then + Disp_Sig_Types := True; + elsif Option = "--disp-signals-map" then + Disp_Signals_Map := True; + elsif Option = "--disp-signals-table" then + Disp_Signals_Table := True; + elsif Option = "--disp-sensitivity" then + Disp_Sensitivity := True; + elsif Option = "--stats" then + Flag_Stats := True; + elsif Option = "--no-run" then + Flag_No_Run := True; + elsif Len > 18 and then Option (1 .. 18) = "--time-resolution=" then + declare + Res : Character; + Unit : String (1 .. 3); + begin + Res := '?'; + if Len >= 20 then + Unit (1) := To_Lower (Option (19)); + Unit (2) := To_Lower (Option (20)); + if Len = 20 then + if Unit (1 .. 2) = "fs" then + Res := 'f'; + elsif Unit (1 .. 2) = "ps" then + Res := 'p'; + elsif Unit (1 .. 2) = "ns" then + Res := 'n'; + elsif Unit (1 .. 2) = "us" then + Res := 'u'; + elsif Unit (1 .. 2) = "ms" then + Res := 'm'; + elsif Unit (1 .. 2) = "hr" then + Res := 'h'; + end if; + elsif Len = 21 then + Unit (3) := To_Lower (Option (21)); + if Unit = "min" then + Res := 'M'; + elsif Unit = "sec" then + Res := 's'; + end if; + end if; + end if; + if Res = '?' then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + else + if Flag_String (5) = '-' then + Error ("time resolution is ignored"); + elsif Flag_String (5) = '?' then + if Stop_Time /= Std_Time'Last then + Error ("time resolution must be set " + & "before --stop-time"); + else + Set_Time_Resolution (Res); + end if; + elsif Flag_String (5) /= Res then + Error ("time resolution is fixed during analysis"); + end if; + end if; + end; + elsif Len > 12 and then Option (1 .. 12) = "--stop-time=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + Unit : String (1 .. 3); + begin + Extract_Integer (Option (13 .. Len), Ok, Time, Pos); + if not Ok then + Time := 1; + end if; + if (Len - Pos + 1) not in 2 .. 3 then + Error_C ("bad unit for '"); + Error_C (Option); + Error_E ("'"); + return; + end if; + Unit (1) := To_Lower (Option (Pos)); + Unit (2) := To_Lower (Option (Pos + 1)); + if Len = Pos + 2 then + Unit (3) := To_Lower (Option (Pos + 2)); + else + Unit (3) := ' '; + end if; + if Unit = "fs " then + null; + elsif Unit = "ps " then + Time := Time * (10 ** 3); + elsif Unit = "ns " then + Time := Time * (10 ** 6); + elsif Unit = "us " then + Time := Time * (10 ** 9); + elsif Unit = "ms " then + Time := Time * (10 ** 12); + elsif Unit = "sec" then + Time := Time * (10 ** 15); + elsif Unit = "min" then + Time := Time * (10 ** 15) * 60; + elsif Unit = "hr " then + Time := Time * (10 ** 15) * 3600; + else + Error_C ("bad unit name for '"); + Error_C (Option); + Error_E ("'"); + end if; + Stop_Time := Std_Time (Time); + end; + elsif Len > 13 and then Option (1 .. 13) = "--stop-delta=" then + declare + Ok : Boolean; + Pos : Natural; + Time : Integer_64; + begin + Extract_Integer (Option (14 .. Len), Ok, Time, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + if Time > Integer_64 (Integer'Last) then + Stop_Delta := Integer'Last; + else + Stop_Delta := Integer (Time); + end if; + end if; + end; + elsif Len > 15 and then Option (1 .. 15) = "--assert-level=" then + if Option (16 .. Len) = "note" then + Severity_Level := Note_Severity; + elsif Option (16 .. Len) = "warning" then + Severity_Level := Warning_Severity; + elsif Option (16 .. Len) = "error" then + Severity_Level := Error_Severity; + elsif Option (16 .. Len) = "failure" then + Severity_Level := Failure_Severity; + elsif Option (16 .. Len) = "none" then + Severity_Level := 4; + else + Error ("bad argument for --assert-level option, try --help"); + end if; + elsif Len > 15 and then Option (1 .. 15) = "--ieee-asserts=" then + if Option (16 .. Len) = "disable" then + Ieee_Asserts := Disable_Asserts; + elsif Option (16 .. Len) = "enable" then + Ieee_Asserts := Enable_Asserts; + elsif Option (16 .. Len) = "disable-at-0" then + Ieee_Asserts := Disable_Asserts_At_Time_0; + else + Error ("bad argument for --ieee-asserts option, try --help"); + end if; + 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; + 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; + elsif Len >= 11 and then Option (1 .. 11) = "--activity=" then + if Option (12 .. Len) = "none" then + Flag_Activity := Activity_None; + elsif Option (12 .. Len) = "min" then + Flag_Activity := Activity_Minimal; + elsif Option (12 .. Len) = "all" then + Flag_Activity := Activity_All; + else + Error ("bad argument for --activity, try --help"); + end if; + elsif Len > 10 and then Option (1 .. 10) = "--threads=" then + declare + Ok : Boolean; + Pos : Natural; + Val : Integer_64; + begin + Extract_Integer (Option (11 .. Len), Ok, Val, Pos); + if not Ok or else Pos <= Len then + Error_C ("bad value in '"); + Error_C (Option); + Error_E ("'"); + else + Nbr_Threads := Integer (Val); + end if; + end; + elsif not Grt.Hooks.Call_Option_Hooks (Option) then + Error_C ("unknown option '"); + Error_C (Option); + Error_E ("', try --help"); + end if; + end Decode_Option; + + procedure Decode (Stop : out Boolean) + is + Arg : Ghdl_C_String; + Len : Natural; + Status : Decode_Option_Status; + begin + Stop := False; + Last_Opt := Argc - 1; + for I in 1 .. Argc - 1 loop + Arg := Argv (I); + Len := strlen (Arg); + declare + Argument : constant String := Arg (1 .. Len); + begin + Decode_Option (Argument, Status); + case Status is + when Decode_Option_Last => + Last_Opt := I; + exit; + when Decode_Option_Help => + Stop := True; + when Decode_Option_Ok => + null; + end case; + end; + end loop; + end Decode; +end Grt.Options; diff --git a/src/translate/grt/grt-options.ads b/src/translate/grt/grt-options.ads new file mode 100644 index 0000000..88b1f50 --- /dev/null +++ b/src/translate/grt/grt-options.ads @@ -0,0 +1,154 @@ +-- GHDL Run Time (GRT) - command line options. +-- 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.Types; use Grt.Types; +with Grt.Lib; use Grt.Lib; + +package Grt.Options is + pragma Preelaborate (Grt.Options); + + -- Name of the program, set by argv[0]. + -- Must be set before calling DECODE. + Progname : Ghdl_C_String; + + -- Arguments. + -- This mimics argc/argv of 'main'. + -- These must be set before calling DECODE. + Argc : Integer; + + type Argv_Array_Type is array (Natural) of Ghdl_C_String; + type Argv_Type is access Argv_Array_Type; + + Argv : Argv_Type; + + -- Last option decoded. + -- Following arguments are reserved for the program. + Last_Opt : Integer; + + -- Consistent flags used for analysis. + -- Format is "VVitr", where: + -- 'VV' is the version (87, 93 or 08). + -- 'i' is the integer size ('i' for 32 bits, 'I' for 64 bits). + -- 't' is the time size ('t' for 32 bits, 'T' for 64 bits). + -- 'r' is the resolution ('?' for to be set by the user, '-' for any). + Flag_String : constant String (1 .. 5); + pragma Import (C, Flag_String, "__ghdl_flag_string"); + + -- Display options help. + -- Should not be called directly. + procedure Help; + + -- Status from Decode_Option. + type Decode_Option_Status is + ( + -- Last option, next arguments aren't options. + Decode_Option_Last, + + -- --help option, program shouldn't run. + Decode_Option_Help, + + -- Option was successfuly decoded. + Decode_Option_Ok); + + -- Decode option Option and set Status. + procedure Decode_Option + (Option : String; Status : out Decode_Option_Status); + + -- Decode command line options. + -- If STOP is true, there nothing must happen (set by --help). + procedure Decode (Stop : out Boolean); + + -- Set by --disp-time (and --trace-signals, --trace-processes) to display + -- time and deltas. + Disp_Time : Boolean := False; + + -- Set by --trace-signals, to display signals after each cycle. + Trace_Signals : Boolean := False; + + -- Set by --trace-processes, to display process name before being run. + Trace_Processes : Boolean := False; + + -- Set by --disp-sig-types, to display signals and they types. + Disp_Sig_Types : Boolean := False; + + Disp_Sources : Boolean := False; + Disp_Signals_Map : Boolean := False; + Disp_Signals_Table : Boolean := False; + Disp_Sensitivity : Boolean := False; + + -- Set by --disp-order to diplay evaluation order of signals. + Disp_Signals_Order : Boolean := False; + + -- Set by --stats to display statistics. + Flag_Stats : Boolean := False; + + -- Set by --checks to do internal checks. + Checks : Boolean := False; + + -- Level at which an assert stop the simulation. + Severity_Level : Integer := Failure_Severity; + + -- How assertions are handled. + type Assert_Handling is + (Enable_Asserts, + Disable_Asserts_At_Time_0, + Disable_Asserts); + + -- Handling of assertions from IEEE library. + Ieee_Asserts : Assert_Handling := Enable_Asserts; + + -- Set by --stop-time=XXX to stop the simulation at or just after XXX. + -- (unit is fs in fact). + Stop_Time : Std_Time := Std_Time'Last; + + -- 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; + + type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None); + Flag_Activity : Activity_Mode := Activity_Minimal; + + -- Set by --thread= + -- Number of threads used to do the simulation. + -- 1 mean no additionnal threads, 0 means as many threads as number of + -- CPUs. + Nbr_Threads : Natural := 1; + + -- Set the time resolution. + -- Only call this subprogram if you are allowed to set the time resolution. + procedure Set_Time_Resolution (Res : Character); +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/translate/grt/grt-processes.adb b/src/translate/grt/grt-processes.adb new file mode 100644 index 0000000..64db682 --- /dev/null +++ b/src/translate/grt/grt-processes.adb @@ -0,0 +1,1042 @@ +-- 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); + if Sig.Event_List /= null and then Sig.Event_List.Dynamic then + Sig.Event_List.Prev := El; + end if; + Sig.Event_List := El; + Proc.Sensitivity := El; + end Ghdl_Process_Wait_Add_Sensitivity; + + procedure Update_Process_First_Timeout (Proc : Process_Acc) is + begin + if Proc.Timeout < Process_First_Timeout then + Process_First_Timeout := Proc.Timeout; + end if; + 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; diff --git a/src/translate/grt/grt-processes.ads b/src/translate/grt/grt-processes.ads new file mode 100644 index 0000000..22326eb --- /dev/null +++ b/src/translate/grt/grt-processes.ads @@ -0,0 +1,260 @@ +-- 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 System; +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; + +package Grt.Processes is + pragma Suppress (All_Checks); + + -- Internal initialisations. + procedure Init; + + -- Do the VHDL simulation. + -- Return 0 in case of success (end of time reached). + function Simulation return Integer; + + -- Number of delta cycles. + Nbr_Delta_Cycles : Integer; + -- Number of non-delta cycles. + Nbr_Cycles : Integer; + + -- 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; + + -- Return the identifier of the current process. + -- During the elaboration, this is the identifier of the last process + -- being elaborated. So, this function can be used to create signal + -- drivers. + + -- Return the total number of processes and number of sensitized processes. + -- Used for statistics. + function Get_Nbr_Processes return Natural; + function Get_Nbr_Sensitized_Processes return Natural; + + -- Total number of resumed processes. + function Get_Nbr_Resumed_Processes return Natural; + + -- Disp the name of process PROC. + procedure Disp_Process_Name (Stream : Grt.Stdio.FILEs; Proc : Process_Acc); + + -- Register a process during elaboration. + -- This procedure is called by vhdl elaboration code. + procedure Ghdl_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Sensitized_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Process_Register (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + procedure Ghdl_Postponed_Sensitized_Process_Register + (Instance : Instance_Acc; + Proc : Proc_Acc; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + -- For verilog processes. + procedure Ghdl_Finalize_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + procedure Ghdl_Initial_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + procedure Ghdl_Always_Register (Instance : Instance_Acc; + Proc : Proc_Acc); + + -- Add a simple signal in the sensitivity of the last registered + -- (sensitized) process. + procedure Ghdl_Process_Add_Sensitivity (Sig : Ghdl_Signal_Ptr); + + -- Resume a process. + procedure Resume_Process (Proc : Process_Acc); + + -- Wait without timeout or sensitivity: wait; + procedure Ghdl_Process_Wait_Exit; + -- Wait for a timeout (without sensitivity): wait for X; + procedure Ghdl_Process_Wait_Timeout (Time : Std_Time); + + -- Full wait statement: + -- 1. Call Ghdl_Process_Wait_Set_Timeout (if there is a timeout) + -- 2. Call Ghdl_Process_Wait_Add_Sensitivity (for each signal) + -- 3. Call Ghdl_Process_Wait_Suspend, go to 4 if it returns true (timeout) + -- Evaluate the condition and go to 4 if true + -- Else, restart 3 + -- 4. Call Ghdl_Process_Wait_Close + + -- Add a timeout for a wait. + procedure Ghdl_Process_Wait_Set_Timeout (Time : Std_Time); + -- 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; + -- 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); + + -- Secondary stack. + function Ghdl_Stack2_Allocate (Size : Ghdl_Index_Type) + return System.Address; + function Ghdl_Stack2_Mark return Mark_Id; + procedure Ghdl_Stack2_Release (Mark : Mark_Id); + + -- Protected variables. + procedure Ghdl_Protected_Enter (Obj : System.Address); + procedure Ghdl_Protected_Leave (Obj : System.Address); + 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 + -- State of a process. + type Process_State is + ( + -- Sensitized process. Its state cannot change. + State_Sensitized, + + -- Non-sensitized process, ready to run. + State_Ready, + + -- Verilog process, being suspended. + State_Delayed, + + -- Non-sensitized process being suspended. + State_Wait, + + -- Non-sensitized process being awaked by a wait timeout. This state + -- is transcient. + -- This is necessary so that the process will exit immediately from the + -- wait statements without checking if the wait condition is true. + State_Timeout, + + -- Non-sensitized process waiting until end. + 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 : Process_State; + + -- Timeout value for wait. + Timeout : Std_Time; + + -- Sensitivity list while the (non-sensitized) process is waiting. + Sensitivity : Action_List_Acc; + + Timeout_Chain_Next : Process_Acc; + Timeout_Chain_Prev : Process_Acc; + end record; + + pragma Export (C, Ghdl_Process_Register, + "__ghdl_process_register"); + pragma Export (C, Ghdl_Sensitized_Process_Register, + "__ghdl_sensitized_process_register"); + pragma Export (C, Ghdl_Postponed_Process_Register, + "__ghdl_postponed_process_register"); + pragma Export (C, Ghdl_Postponed_Sensitized_Process_Register, + "__ghdl_postponed_sensitized_process_register"); + + pragma Export (C, Ghdl_Finalize_Register, "__ghdl_finalize_register"); + + pragma Export (C, Ghdl_Always_Register, "__ghdl_always_register"); + pragma Export (C, Ghdl_Initial_Register, "__ghdl_initial_register"); + + pragma Export (C, Ghdl_Process_Add_Sensitivity, + "__ghdl_process_add_sensitivity"); + + pragma Export (C, Ghdl_Process_Wait_Exit, + "__ghdl_process_wait_exit"); + pragma Export (C, Ghdl_Process_Wait_Timeout, + "__ghdl_process_wait_timeout"); + pragma Export (C, Ghdl_Process_Wait_Add_Sensitivity, + "__ghdl_process_wait_add_sensitivity"); + pragma Export (C, Ghdl_Process_Wait_Set_Timeout, + "__ghdl_process_wait_set_timeout"); + pragma Export (Ada, Ghdl_Process_Wait_Suspend, + "__ghdl_process_wait_suspend"); + pragma Export (C, Ghdl_Process_Wait_Close, + "__ghdl_process_wait_close"); + + pragma Export (C, Ghdl_Process_Delay, "__ghdl_process_delay"); + + pragma Export (C, Ghdl_Stack2_Allocate, "__ghdl_stack2_allocate"); + pragma Export (C, Ghdl_Stack2_Mark, "__ghdl_stack2_mark"); + pragma Export (C, Ghdl_Stack2_Release, "__ghdl_stack2_release"); + + pragma Export (C, Ghdl_Protected_Enter, "__ghdl_protected_enter"); + pragma Export (C, Ghdl_Protected_Leave, "__ghdl_protected_leave"); + pragma Export (C, Ghdl_Protected_Init, "__ghdl_protected_init"); + pragma Export (C, Ghdl_Protected_Fini, "__ghdl_protected_fini"); +end Grt.Processes; diff --git a/src/translate/grt/grt-readline.ads b/src/translate/grt/grt-readline.ads new file mode 100644 index 0000000..1a30839 --- /dev/null +++ b/src/translate/grt/grt-readline.ads @@ -0,0 +1,30 @@ +-- Although being part of GRT, the readline binding should be independent of +-- it (for easier reuse). + +with System; use System; + +package Grt.Readline is + subtype Fat_String is String (Positive); + type Char_Ptr is access Fat_String; + pragma Convention (C, Char_Ptr); + -- A C string (which is NUL terminated) is represented as a (thin) access + -- to a fat string (a string whose range is 1 .. integer'Last). + -- The use of an access to a constrained array allows a representation + -- compatible with C. Indexing of object of that type is safe only for + -- indexes until the NUL character. + + function Readline (Prompt : Char_Ptr) return Char_Ptr; + function Readline (Prompt : Address) return Char_Ptr; + pragma Import (C, Readline); + + procedure Free (Buf : Char_Ptr); + pragma Import (C, Free); + + procedure Add_History (Line : Char_Ptr); + pragma Import (C, Add_History); + + function Strlen (Str : Char_Ptr) return Natural; + pragma Import (C, Strlen); + + pragma Linker_Options ("-lreadline"); +end Grt.Readline; diff --git a/src/translate/grt/grt-rtis.adb b/src/translate/grt/grt-rtis.adb new file mode 100644 index 0000000..26d9764 --- /dev/null +++ b/src/translate/grt/grt-rtis.adb @@ -0,0 +1,45 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- Copyright (C) 2013 - 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. + +package body Grt.Rtis is + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access) is + begin + Ghdl_Rti_Top.Children (Ghdl_Rti_Top.Nbr_Child) := Pkg; + Ghdl_Rti_Top.Nbr_Child := Ghdl_Rti_Top.Nbr_Child + 1; + end Ghdl_Rti_Add_Package; + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address) + is + pragma Unreferenced (Max_Pkg); + begin + Ghdl_Rti_Top.Parent := Top; + Ghdl_Rti_Top.Children := Pkgs; + Ghdl_Rti_Top_Instance := Instance; + end Ghdl_Rti_Add_Top; + +end Grt.Rtis; diff --git a/src/translate/grt/grt-rtis.ads b/src/translate/grt/grt-rtis.ads new file mode 100644 index 0000000..6bb7659 --- /dev/null +++ b/src/translate/grt/grt-rtis.ads @@ -0,0 +1,379 @@ +-- GHDL Run Time (GRT) - Run Time Informations. +-- 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 Grt.Types; use Grt.Types; +with Ada.Unchecked_Conversion; + +package Grt.Rtis is + pragma Preelaborate (Grt.Rtis); + + type Ghdl_Rtik is + (Ghdl_Rtik_Top, + Ghdl_Rtik_Library, -- use scalar + Ghdl_Rtik_Package, + Ghdl_Rtik_Package_Body, + Ghdl_Rtik_Entity, + Ghdl_Rtik_Architecture, + Ghdl_Rtik_Process, + Ghdl_Rtik_Block, + Ghdl_Rtik_If_Generate, + Ghdl_Rtik_For_Generate, + Ghdl_Rtik_Instance, --10 + Ghdl_Rtik_Constant, + Ghdl_Rtik_Iterator, + Ghdl_Rtik_Variable, + Ghdl_Rtik_Signal, + Ghdl_Rtik_File, -- 15 + Ghdl_Rtik_Port, + Ghdl_Rtik_Generic, + Ghdl_Rtik_Alias, + Ghdl_Rtik_Guard, + Ghdl_Rtik_Component, -- 20 + Ghdl_Rtik_Attribute, + Ghdl_Rtik_Type_B1, -- Enum + Ghdl_Rtik_Type_E8, + Ghdl_Rtik_Type_E32, + Ghdl_Rtik_Type_I32, -- 25 Scalar + Ghdl_Rtik_Type_I64, + Ghdl_Rtik_Type_F64, + Ghdl_Rtik_Type_P32, + Ghdl_Rtik_Type_P64, + Ghdl_Rtik_Type_Access, + Ghdl_Rtik_Type_Array, + Ghdl_Rtik_Type_Record, + Ghdl_Rtik_Type_File, + Ghdl_Rtik_Subtype_Scalar, + Ghdl_Rtik_Subtype_Array, + Ghdl_Rtik_Subtype_Unconstrained_Array, + Ghdl_Rtik_Subtype_Record, + Ghdl_Rtik_Subtype_Access, + Ghdl_Rtik_Type_Protected, + Ghdl_Rtik_Element, + Ghdl_Rtik_Unit64, + Ghdl_Rtik_Unitptr, + Ghdl_Rtik_Attribute_Transaction, + Ghdl_Rtik_Attribute_Quiet, + Ghdl_Rtik_Attribute_Stable, + Ghdl_Rtik_Error); + for Ghdl_Rtik'Size use 8; + + type Ghdl_Rti_Depth is range 0 .. 255; + for Ghdl_Rti_Depth'Size use 8; + + type Ghdl_Rti_U8 is mod 2 ** 8; + for Ghdl_Rti_U8'Size use 8; + + -- This structure is common to all RTI nodes. + type Ghdl_Rti_Common is record + -- Kind of the RTI, list is above. + Kind : Ghdl_Rtik; + + Depth : Ghdl_Rti_Depth; + + -- * array types and subtypes, record types, protected types: + -- bit 0: set for complex type + -- bit 1: set for anonymous type definition + -- bit 2: set only for physical type with non-static units (time) + -- * signals: + -- bit 0-3: mode (1: linkage, 2: buffer, 3 : out, 4 : inout, 5: in) + -- bit 4-5: kind (0 : none, 1 : register, 2 : bus) + -- bit 6: set if has 'active attributes + Mode : Ghdl_Rti_U8; + + -- * Types and subtypes definition: + -- maximum depth of all RTIs referenced. + -- * Others: + -- 0 + Max_Depth : Ghdl_Rti_Depth; + end record; + + type Ghdl_Rti_Access is access all Ghdl_Rti_Common; + + -- Fat array of rti accesses. + type Ghdl_Rti_Array is array (Ghdl_Index_Type) of Ghdl_Rti_Access; + type Ghdl_Rti_Arr_Acc is access Ghdl_Rti_Array; + + subtype Ghdl_Rti_Loc is Integer_Address; + Null_Rti_Loc : constant Ghdl_Rti_Loc := 0; + + type Ghdl_C_String_Array is array (Ghdl_Index_Type) of Ghdl_C_String; + type Ghdl_C_String_Array_Ptr is access Ghdl_C_String_Array; + + type Ghdl_Rtin_Block is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Size : Ghdl_Index_Type; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Block_Acc is access Ghdl_Rtin_Block; + function To_Ghdl_Rtin_Block_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Block_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Block_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Object is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Obj_Type : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Object_Acc is access Ghdl_Rtin_Object; + function To_Ghdl_Rtin_Object_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Object_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Object_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Instance is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Loc : Ghdl_Rti_Loc; + Parent : Ghdl_Rti_Access; + Instance : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Instance_Acc is access Ghdl_Rtin_Instance; + function To_Ghdl_Rtin_Instance_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Instance_Acc); + + -- Must be kept in sync with grt.types.mode_signal_type. + Ghdl_Rti_Signal_Mode_Mask : constant Ghdl_Rti_U8 := 15; + Ghdl_Rti_Signal_Mode_None : constant Ghdl_Rti_U8 := 0; + Ghdl_Rti_Signal_Mode_Linkage : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Signal_Mode_Buffer : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Signal_Mode_Out : constant Ghdl_Rti_U8 := 3; + Ghdl_Rti_Signal_Mode_Inout : constant Ghdl_Rti_U8 := 4; + Ghdl_Rti_Signal_Mode_In : constant Ghdl_Rti_U8 := 5; + + Ghdl_Rti_Signal_Kind_Mask : constant Ghdl_Rti_U8 := 3 * 16; + Ghdl_Rti_Signal_Kind_Offset : constant Ghdl_Rti_U8 := 1 * 16; + Ghdl_Rti_Signal_Kind_No : constant Ghdl_Rti_U8 := 0 * 16; + Ghdl_Rti_Signal_Kind_Register : constant Ghdl_Rti_U8 := 1 * 16; + Ghdl_Rti_Signal_Kind_Bus : constant Ghdl_Rti_U8 := 2 * 16; + + Ghdl_Rti_Signal_Has_Active : constant Ghdl_Rti_U8 := 64; + + type Ghdl_Rtin_Component is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr_Child : Ghdl_Index_Type; + Children : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Component_Acc is access Ghdl_Rtin_Component; + function To_Ghdl_Rtin_Component_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Component_Acc); + + type Ghdl_Rtin_Type_Enum is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + -- Characters are represented as 'X', identifiers are represented as is, + -- extended identifiers are represented as is too. + Names : Ghdl_C_String_Array_Ptr; + end record; + type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum; + function To_Ghdl_Rtin_Type_Enum_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Enum_Acc); + + type Ghdl_Rtin_Type_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + end record; + type Ghdl_Rtin_Type_Scalar_Acc is access Ghdl_Rtin_Type_Scalar; + function To_Ghdl_Rtin_Type_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Scalar_Acc); + + type Ghdl_Rtin_Subtype_Scalar is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rti_Access; + Range_Loc : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Scalar_Acc is access Ghdl_Rtin_Subtype_Scalar; + function To_Ghdl_Rtin_Subtype_Scalar_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Scalar_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Subtype_Scalar_Acc, Target => Ghdl_Rti_Access); + + -- True if the type is complex, set in Mode field. + Ghdl_Rti_Type_Complex_Mask : constant Ghdl_Rti_U8 := 1; + Ghdl_Rti_Type_Complex : constant Ghdl_Rti_U8 := 1; + + -- True if the type is anonymous + Ghdl_Rti_Type_Anonymous_Mask : constant Ghdl_Rti_U8 := 2; + Ghdl_Rti_Type_Anonymous : constant Ghdl_Rti_U8 := 2; + + type Ghdl_Rtin_Type_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Element : Ghdl_Rti_Access; + Nbr_Dim : Ghdl_Index_Type; + Indexes : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Array_Acc is access Ghdl_Rtin_Type_Array; + function To_Ghdl_Rtin_Type_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Type_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Subtype_Array is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Basetype : Ghdl_Rtin_Type_Array_Acc; + Bounds : Ghdl_Rti_Loc; + Valsize : Ghdl_Rti_Loc; + Sigsize : Ghdl_Rti_Loc; + end record; + type Ghdl_Rtin_Subtype_Array_Acc is access Ghdl_Rtin_Subtype_Array; + function To_Ghdl_Rtin_Subtype_Array_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Subtype_Array_Acc); + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Ghdl_Rtin_Subtype_Array_Acc, Target => Ghdl_Rti_Access); + + type Ghdl_Rtin_Type_Fileacc is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Base : Ghdl_Rti_Access; + end record; + type Ghdl_Rtin_Type_Fileacc_Acc is access Ghdl_Rtin_Type_Fileacc; + function To_Ghdl_Rtin_Type_Fileacc_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Fileacc_Acc); + + type Ghdl_Rtin_Element is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Eltype : Ghdl_Rti_Access; + Val_Off : Ghdl_Index_Type; + Sig_Off : Ghdl_Index_Type; + end record; + type Ghdl_Rtin_Element_Acc is access Ghdl_Rtin_Element; + function To_Ghdl_Rtin_Element_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Element_Acc); + + type Ghdl_Rtin_Type_Record is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbrel : Ghdl_Index_Type; + Elements : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Record_Acc is access Ghdl_Rtin_Type_Record; + function To_Ghdl_Rtin_Type_Record_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Record_Acc); + + type Ghdl_Rtin_Unit64 is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Value : Ghdl_I64; + end record; + type Ghdl_Rtin_Unit64_Acc is access Ghdl_Rtin_Unit64; + function To_Ghdl_Rtin_Unit64_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unit64_Acc); + + type Ghdl_Rtin_Unitptr is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Addr : Ghdl_Value_Ptr; + end record; + type Ghdl_Rtin_Unitptr_Acc is access Ghdl_Rtin_Unitptr; + function To_Ghdl_Rtin_Unitptr_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Unitptr_Acc); + + -- Mode field is set to 4 if units value is per address. Otherwise, + -- mode is 0. + type Ghdl_Rtin_Type_Physical is record + Common : Ghdl_Rti_Common; + Name : Ghdl_C_String; + Nbr : Ghdl_Index_Type; + Units : Ghdl_Rti_Arr_Acc; + end record; + type Ghdl_Rtin_Type_Physical_Acc is access Ghdl_Rtin_Type_Physical; + function To_Ghdl_Rtin_Type_Physical_Acc is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Ghdl_Rtin_Type_Physical_Acc); + + -- Instance linkage. + + -- At the beginning of a component structure (or the object for a direct + -- instantiation), there is a Ghdl_Component_Link_Type record. + -- These record contains a pointer to the instance (down link), + -- and RTIS to the statement and its parent (up link). + type Ghdl_Component_Link_Type; + type Ghdl_Component_Link_Acc is access Ghdl_Component_Link_Type; + + -- At the beginning of an entity structure, there is a Ghdl_Link_Type, + -- which contains the RTI for the architecture (down-link) and a pointer + -- to the instantiation object (up-link). + type Ghdl_Entity_Link_Type is record + Rti : Ghdl_Rti_Access; + Parent : Ghdl_Component_Link_Acc; + end record; + + type Ghdl_Entity_Link_Acc is access Ghdl_Entity_Link_Type; + + function To_Ghdl_Entity_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Entity_Link_Acc); + + type Ghdl_Component_Link_Type is record + Instance : Ghdl_Entity_Link_Acc; + Stmt : Ghdl_Rti_Access; + end record; + + function To_Ghdl_Component_Link_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Component_Link_Acc); + + -- TOP rti. + Ghdl_Rti_Top : Ghdl_Rtin_Block := + (Common => (Ghdl_Rtik_Top, 0, 0, 0), + Name => null, + Loc => Null_Rti_Loc, + Parent => null, + Size => 0, + Nbr_Child => 0, + Children => null); + + -- Address of the top instance. + Ghdl_Rti_Top_Instance : Address; + + -- Instances have a pointer to their RTI at offset 0. + type Ghdl_Rti_Acc_Acc is access Ghdl_Rti_Access; + function To_Ghdl_Rti_Acc_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Acc_Acc); + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Rti_Access, Target => Address); + + function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Rti_Access); + + procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type; + Pkgs : Ghdl_Rti_Arr_Acc; + Top : Ghdl_Rti_Access; + Instance : Address); + pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top"); + + -- Register a package + procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access); + pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package"); +end Grt.Rtis; diff --git a/src/translate/grt/grt-rtis_addr.adb b/src/translate/grt/grt-rtis_addr.adb new file mode 100644 index 0000000..70a0e21 --- /dev/null +++ b/src/translate/grt/grt-rtis_addr.adb @@ -0,0 +1,299 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- 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.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) + R); + end "+"; + + function "+" (L : Address; R : Ghdl_Index_Type) return Address + is + begin + return To_Address (To_Integer (L) + Integer_Address (R)); + end "+"; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) - R); + end "-"; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address + is + Nad : Integer_Address; + begin + Nad := To_Integer (L + (R - 1)); + return To_Address (Nad - (Nad mod R)); + end Align; + + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context + is + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + return (Base => Ctxt.Base - Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_Architecture => + if Blk.Loc /= Null_Rti_Loc then + Internal_Error ("get_parent_context(3)"); + end if; + return (Base => Ctxt.Base + Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + declare + Nbase : Address; + Parent : Ghdl_Rti_Access; + Blk1 : Ghdl_Rtin_Block_Acc; + begin + -- Read the pointer to the parent. + -- This is the first field. + Nbase := To_Addr_Acc (Ctxt.Base).all; + -- Since the parent may be a grant-parent, adjust + -- the base. + Parent := Blk.Parent; + loop + case Parent.Kind is + when Ghdl_Rtik_Architecture + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + exit; + when Ghdl_Rtik_Block => + Blk1 := To_Ghdl_Rtin_Block_Acc (Parent); + Nbase := Nbase + Blk1.Loc; + Parent := Blk1.Parent; + when others => + Internal_Error ("get_parent_context(2)"); + end case; + end loop; + return (Base => Nbase, + Block => Blk.Parent); + end; + when others => + Internal_Error ("get_parent_context(1)"); + end case; + end Get_Parent_Context; + + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access) + is + Obj : Ghdl_Rtin_Instance_Acc; + begin + if Link.Parent = null then + -- Top entity. + Stmt := null; + Ctxt := (Base => Null_Address, Block => null); + else + Stmt := Link.Parent.Stmt; + Obj := To_Ghdl_Rtin_Instance_Acc (Stmt); + Ctxt := (Base => Link.Parent.all'Address - Obj.Loc, + Block => Obj.Parent); + end if; + end Get_Instance_Link; + + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address + is + Cur_Ctxt : Rti_Context; + Nctxt : Rti_Context; + begin + if Depth = 0 then + return To_Address (Loc); + elsif Ctxt.Block.Depth = Depth then + --Addr := Base + Storage_Offset (Obj.Loc.Off); + return Ctxt.Base + Loc; + else + if Ctxt.Block.Depth < Depth then + Internal_Error ("loc_to_addr"); + end if; + Cur_Ctxt := Ctxt; + loop + Nctxt := Get_Parent_Context (Cur_Ctxt); + if Nctxt.Block.Depth = Depth then + return Nctxt.Base + Loc; + end if; + Cur_Ctxt := Nctxt; + end loop; + end if; + end Loc_To_Addr; + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + begin + case Base_Type.Kind is + when Ghdl_Rtik_Type_B1 => + return Rng.B1.Len; + when Ghdl_Rtik_Type_E8 => + return Rng.E8.Len; + when Ghdl_Rtik_Type_E32 => + return Rng.E32.Len; + when Ghdl_Rtik_Type_I32 => + return Rng.I32.Len; + when others => + Internal_Error ("range_to_length"); + end case; + end Range_To_Length; + + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type + is + Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc; + Rng : Ghdl_Range_Ptr; + begin + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type); + if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then + Internal_Error ("get_for_generate_length(1)"); + end if; + Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt)); + return Range_To_Length (Rng, Iter_Type.Basetype); + end Get_For_Generate_Length; + + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context) + is + Inst_Addr : Address; + Inst_Base : Address; + begin + -- Address of the field containing the address of the instance. + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance address. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + -- Read instance RTI. + if Inst_Base = Null_Address then + Sub_Ctxt := (Base => Null_Address, Block => null); + else + Sub_Ctxt := (Base => Inst_Base, + Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all); + end if; + end Get_Instance_Context; + + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + Idx_Def : Ghdl_Rti_Access; + begin + if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then + Internal_Error ("disp_rti.bound_to_range"); + end if; + + Bounds := Bounds_Addr; + + for I in 0 .. Def.Nbr_Dim - 1 loop + Idx_Def := Def.Indexes (I); + + if Bounds = Null_Address then + Res (I) := null; + else + Idx_Def := Get_Base_Type (Idx_Def); + case Idx_Def.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_I32'Size); + when Ghdl_Rtik_Type_E8 => + Align (Ghdl_Range_E8'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E8'Size); + when Ghdl_Rtik_Type_E32 => + Align (Ghdl_Range_E32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E32'Size); + when others => + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end loop; + end Bound_To_Range; + + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access + is + begin + case Atype.Kind is + when Ghdl_Rtik_Subtype_Scalar => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; + when Ghdl_Rtik_Subtype_Array => + return To_Ghdl_Rti_Access + (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + return Atype; + when others => + Internal_Error ("rtis_addr.get_base_type"); + end case; + end Get_Base_Type; + + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) + = Ghdl_Rti_Type_Complex; + end Rti_Complex_Type; + + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) + = Ghdl_Rti_Type_Anonymous; + end Rti_Anonymous_Type; + + function Get_Top_Context return Rti_Context + is + Ctxt : Rti_Context; + begin + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + return Ctxt; + end Get_Top_Context; + +end Grt.Rtis_Addr; diff --git a/src/translate/grt/grt-rtis_addr.ads b/src/translate/grt/grt-rtis_addr.ads new file mode 100644 index 0000000..3fa2792 --- /dev/null +++ b/src/translate/grt/grt-rtis_addr.ads @@ -0,0 +1,110 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- 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; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +-- Addresses handling. +package Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address; + function "+" (L : Address; R : Ghdl_Index_Type) return Address; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address; + + -- An RTI context contains a pointer (BASE) to or into an instance. + -- BLOCK describes data being pointed. If a reference is made to a field + -- described by a parent of BLOCK, BASE must be modified. + type Rti_Context is record + Base : Address; + Block : Ghdl_Rti_Access; + end record; + + Null_Context : constant Rti_Context; + + -- Access to an address. + type Addr_Acc is access Address; + function To_Addr_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Addr_Acc); + + type Ghdl_Index_Acc is access Ghdl_Index_Type; + function To_Ghdl_Index_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Index_Acc); + + -- Get the parent context of CTXT. + -- The parent of an architecture is its entity. + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context; + + -- From an entity link, extract context and instantiation statement. + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access); + + -- Convert a location to an address. + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address; + + -- Get the length of for_generate BLK. + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type; + + -- Get the context of instance INST. + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context); + + -- Extract range of every dimension from bounds. + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array); + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type; + + -- Get the base type of ATYPE. + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access; + + -- Return true iff ATYPE is anonymous. + -- Valid only on type and subtype definitions. + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Anonymous_Type); + + -- Return true iff ATYPE is complex. + -- Valid only on type and subtype definitions. + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean; + pragma Inline (Rti_Complex_Type); + + -- Get the top context. + function Get_Top_Context return Rti_Context; + +private + Null_Context : constant Rti_Context := (Base => Null_Address, + Block => null); +end Grt.Rtis_Addr; diff --git a/src/translate/grt/grt-rtis_binding.ads b/src/translate/grt/grt-rtis_binding.ads new file mode 100644 index 0000000..7e90eea --- /dev/null +++ b/src/translate/grt/grt-rtis_binding.ads @@ -0,0 +1,67 @@ +-- GHDL Run Time (GRT) - Well known RTIs. +-- 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 Grt.Rtis; use Grt.Rtis; + +-- Set RTI_ptr defined in grt.rtis_types. + +package Grt.Rtis_Binding is + pragma Preelaborate (Grt.Rtis_Binding); + + -- Define and set bit and boolean RTIs. + Std_Standard_Bit_RTI : aliased Ghdl_Rti_Common; + + Std_Standard_Boolean_RTI : aliased Ghdl_Rti_Common; + + pragma Import (C, Std_Standard_Bit_RTI, + "std__standard__bit__RTI"); + + pragma Import (C, Std_Standard_Boolean_RTI, + "std__standard__boolean__RTI"); + + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Bit_RTI'Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access + := Std_Standard_Boolean_RTI'Access; + + pragma Export (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Export (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); + + + -- Define and set Resolved_Resolv_Ptr. + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address := + Ieee_Std_Logic_1164_Resolved_RESOLV'Address; + pragma Export (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + +end Grt.Rtis_Binding; diff --git a/src/translate/grt/grt-rtis_types.adb b/src/translate/grt/grt-rtis_types.adb new file mode 100644 index 0000000..f22a309 --- /dev/null +++ b/src/translate/grt/grt-rtis_types.adb @@ -0,0 +1,118 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- 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.Astdio; +with Grt.Avhpi; use Grt.Avhpi; + +package body Grt.Rtis_Types is + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + use Grt.Astdio; + pragma Unreferenced (Err); + begin + Put_Line ("grt.rtis_utils.Avhpi_Error!"); + end Avhpi_Error; + + -- Extract std_ulogic type. + procedure Search_Types (Pack : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + Rti : Ghdl_Rti_Access; + begin + Vhpi_Get_Str (VhpiLibLogicalNameP, Pack, Name, Name_Len); + if not (Name_Len = 4 and then Name (1 .. 4)= "ieee") then + return; + end if; + + Vhpi_Iterator (VhpiDecls, Pack, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract packages. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + if Vhpi_Get_Kind (Decl) = VhpiEnumTypeDeclK then + Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len); + Rti := Avhpi_Get_Rti (Decl); + if Name_Len = 10 and then Name (1 .. 10) = "std_ulogic" then + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr := Rti; + end if; + end if; + end loop; + end Search_Types; + + procedure Search_Packages + is + Pack : VhpiHandleT; + Pack_It : VhpiHandleT; + + Error : AvhpiErrorT; + Name : String (1 .. 16); + Name_Len : Natural; + begin + Get_Package_Inst (Pack_It); + + -- Extract packages. + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Vhpi_Get_Str (VhpiNameP, Pack, Name, Name_Len); + if Name_Len = 14 and then Name (1 .. 14) = "std_logic_1164" then + Search_Types (Pack); + end if; + end loop; + end Search_Packages; + + Search_Types_RTI_Done : Boolean := False; + + procedure Search_Types_RTI is + begin + if Search_Types_RTI_Done then + return; + else + Search_Types_RTI_Done := True; + end if; + + Search_Packages; + end Search_Types_RTI; +end Grt.Rtis_Types; diff --git a/src/translate/grt/grt-rtis_types.ads b/src/translate/grt/grt-rtis_types.ads new file mode 100644 index 0000000..f64b173 --- /dev/null +++ b/src/translate/grt/grt-rtis_types.ads @@ -0,0 +1,55 @@ +-- GHDL Run Time (GRT) - Well known RTI types. +-- 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.Rtis; use Grt.Rtis; + +-- This package allow access to RTIs of some types. +-- This is used to recognize some VHDL logic types. +-- This is also used by grt.signals to set types of some implicit signals +-- (such as 'stable or 'transation). + +package Grt.Rtis_Types is + -- RTIs for some logic types. + Std_Standard_Bit_RTI_Ptr : Ghdl_Rti_Access; + + Std_Standard_Boolean_RTI_Ptr : Ghdl_Rti_Access; + + -- std_ulogic. + -- A VHDL may not contain ieee.std_logic_1164 package. So, this RTI + -- must be dynamicaly searched. + Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr : Ghdl_Rti_Access := null; + + -- Search RTI for types. + -- If a type is not found, its RTI is set to null. + -- If this procedure has already been called, then this is a noop. + procedure Search_Types_RTI; +private + -- These are set either by grt.rtis_binding or by ghdlrun. + -- This is not very clean... + pragma Import (C, Std_Standard_Bit_RTI_Ptr, + "std__standard__bit__RTI_ptr"); + + pragma Import (C, Std_Standard_Boolean_RTI_Ptr, + "std__standard__boolean__RTI_ptr"); +end Grt.Rtis_Types; diff --git a/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb new file mode 100644 index 0000000..0d4328e --- /dev/null +++ b/src/translate/grt/grt-rtis_utils.adb @@ -0,0 +1,660 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- 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.Disp; use Grt.Disp; +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Utils is + + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result + is + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result; + + function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + Index : Ghdl_Index_Type; + Child : Ghdl_Rti_Access; + begin + Res := Process (Ctxt, Ctxt.Block); + if Res /= Traverse_Ok then + return Res; + end if; + + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + Index := 0; + while Index < Blk.Nbr_Child loop + Child := Blk.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Res := Traverse_Blocks_1 (Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + Length : Ghdl_Index_Type; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + for I in 1 .. Length loop + Res := Traverse_Blocks_1 (Nctxt); + exit when Res = Traverse_Stop; + Nctxt.Base := Nctxt.Base + Nblk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + Res := Process (Ctxt, Child); + if Res = Traverse_Ok then + declare + Obj : Ghdl_Rtin_Instance_Acc; + begin + Obj := To_Ghdl_Rtin_Instance_Acc (Child); + + Get_Instance_Context (Obj, Ctxt, Nctxt); + if Nctxt /= Null_Context then + Res := Traverse_Instance (Nctxt); + end if; + end; + end if; + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Internal_Error ("traverse_blocks"); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Res := Process (Ctxt, Child); + when others => + null; + end case; + exit when Res = Traverse_Stop; + end loop; + + return Res; + end Traverse_Blocks_1; + + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + -- The entity. + Res := Traverse_Blocks_1 (Nctxt); + if Res /= Traverse_Stop then + -- The architecture. + Res := Traverse_Blocks_1 (Ctxt); + end if; + when Ghdl_Rtik_Package_Body => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Res := Traverse_Blocks_1 (Nctxt); + when others => + Internal_Error ("traverse_blocks"); + end case; + return Res; + end Traverse_Instance; + begin + return Traverse_Instance (Ctxt); + end Traverse_Blocks; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Get_Enum_Value + (Vstr : in out Vstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Append (Vstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type) + is + -- Current address. + Addr : Address; + + Name : Vstring; + + procedure Handle_Any (Rti : Ghdl_Rti_Access); + + procedure Handle_Scalar (Rti : Ghdl_Rti_Access) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + begin + Process (Addr, Name, Rti, Param); + + if Is_Sig then + Update (Address'Size); + else + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Update (32); + when Ghdl_Rtik_Type_E8 => + Update (8); + when Ghdl_Rtik_Type_E32 => + Update (32); + when Ghdl_Rtik_Type_B1 => + Update (8); + when Ghdl_Rtik_Type_F64 => + Update (64); + when Ghdl_Rtik_Type_P64 => + Update (64); + when others => + Internal_Error ("handle_scalar"); + end case; + end if; + end Handle_Scalar; + + procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type; + Val : out Value_Union) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + case Rng.I32.Dir is + when Dir_To => + Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos); + when Dir_Downto => + Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos); + end case; + when Ghdl_Rtik_Type_E8 => + case Rng.E8.Dir is + when Dir_To => + Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos); + when Dir_Downto => + Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos); + end case; + when Ghdl_Rtik_Type_E32 => + case Rng.E32.Dir is + when Dir_To => + Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos); + when Dir_Downto => + Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos); + end case; + when Ghdl_Rtik_Type_B1 => + case Pos is + when 0 => + Val.B1 := Rng.B1.Left; + when 1 => + Val.B1 := Rng.B1.Right; + when others => + Val.B1 := False; + end case; + when others => + Internal_Error ("grt.rtis_utils.range_pos_to_val"); + end case; + end Range_Pos_To_Val; + + procedure Pos_To_Vstring + (Vstr : in out Vstring; + Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type) + is + V : Value_Union; + begin + Range_Pos_To_Val (Rti, Rng, Pos, V); + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, V.I32); + Append (Vstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1)); + when others => + Append (Vstr, '?'); + end case; + end Pos_To_Vstring; + + procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type) + is + Len : Ghdl_Index_Type; + P : Natural; + Base_Type : Ghdl_Rti_Access; + begin + P := Length (Name); + if Index = 0 then + Append (Name, '('); + else + Append (Name, ','); + end if; + + Base_Type := Get_Base_Type (Rtis (Index)); + Len := Range_To_Length (Rngs (Index), Base_Type); + + for I in 1 .. Len loop + Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); + if Index = Rngs'Last then + Append (Name, ')'); + Handle_Any (El_Rti); + else + Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + end if; + Truncate (Name, P + 1); + end loop; + Truncate (Name, P); + end Handle_Array_1; + + procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; + Vals : Ghdl_Uc_Array_Acc) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Addr := Vals.Base; + Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + end Handle_Array; + + procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) + is + El : Ghdl_Rtin_Element_Acc; + Obj_Addr : Address; + Last_Addr : Address; + P : Natural; + begin + P := Length (Name); + Obj_Addr := Addr; + Last_Addr := Addr; + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if Is_Sig then + Addr := Obj_Addr + El.Sig_Off; + else + Addr := Obj_Addr + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all; + end if; + Append (Name, '.'); + Append (Name, El.Name); + Handle_Any (El.Eltype); + if Addr > Last_Addr then + Last_Addr := Addr; + end if; + Truncate (Name, P); + end loop; + Addr := Last_Addr; + end Handle_Record; + + procedure Handle_Any (Rti : Ghdl_Rti_Access) is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Handle_Scalar (Rti); + when Ghdl_Rtik_Type_Array => + Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti), + To_Ghdl_Uc_Array_Acc (Addr)); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + end; +-- when Ghdl_Rtik_Type_File => +-- declare +-- Vptr : Ghdl_Value_Ptr; +-- begin +-- Vptr := To_Ghdl_Value_Ptr (Obj); +-- Put (Stream, "File#"); +-- Put_I32 (Stream, Vptr.I32); +-- -- FIXME: update OBJ (not very useful since never in a +-- -- composite type). +-- end; + when Ghdl_Rtik_Type_Record => + Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); + when others => + Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any"); + end case; + end Handle_Any; + begin + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Obj_Addr).all; + else + Addr := Obj_Addr; + end if; + Handle_Any (Obj_Type); + Free (Name); + end Foreach_Scalar; + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when Ghdl_Rtik_Type_F64 => + declare + S : String (1 .. 32); + L : Integer; + + function Snprintf_G (Cstr : Address; + Size : Natural; + Arg : Ghdl_F64) + return Integer; + pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + + begin + L := Snprintf_G (S'Address, S'Length, Value.F64); + if L < 0 then + -- FIXME. + Append (Str, "?"); + else + Append (Str, S (1 .. L)); + end if; + end; + when Ghdl_Rtik_Type_P32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when Ghdl_Rtik_Type_P64 => + declare + S : String (1 .. 21); + F : Natural; + begin + To_String (S, F, Value.I64); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when others => + Internal_Error ("grt.rtis_utils.get_value"); + end case; + end Get_Value; + + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + Name : Vstring; + begin + Rtis_Utils.Get_Value (Name, Value, Type_Rti); + Put (Stream, Name); + Free (Name); + end Disp_Value; + + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String + is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Name; + when Ghdl_Rtik_Unitptr => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name; + when others => + Internal_Error ("rtis_utils.physical_unit_name"); + end case; + end Get_Physical_Unit_Name; + + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64 is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Value; + when Ghdl_Rtik_Unitptr => + case Type_Rti.Kind is + when Ghdl_Rtik_Type_P64 => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64; + when Ghdl_Rtik_Type_P32 => + return Ghdl_I64 + (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error ("get_physical_unit_value(1)"); + end case; + when others => + Internal_Error ("get_physical_unit_value(2)"); + end case; + end Get_Physical_Unit_Value; + + procedure Get_Enum_Value + (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Prepend (Rstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Get_Value (Rstr : in out Rstring; + Addr : Address; + Type_Rti : Ghdl_Rti_Access) + is + Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Prepend (Rstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when others => + Internal_Error ("grt.rtis_utils.get_value(rstr)"); + end case; + end Get_Value; + + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True) + is + Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + begin + Ctxt := Last_Ctxt; + loop + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Entity => + declare + Link : Ghdl_Entity_Link_Acc; + begin + Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base); + Ctxt := (Base => Ctxt.Base, + Block => Link.Rti); + if Ctxt.Block = null then + -- Process in an entity. + -- FIXME: check. + Prepend (Rstr, Blk.Name); + return; + end if; + end; + when Ghdl_Rtik_Architecture => + declare + Entity_Ctxt: Rti_Context; + Link : Ghdl_Entity_Link_Acc; + Parent_Inst : Ghdl_Rti_Access; + begin + -- Architecture name. + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, '('); + end if; + + Entity_Ctxt := Get_Parent_Context (Ctxt); + + -- Instance parent. + Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base); + Get_Instance_Link (Link, Ctxt, Parent_Inst); + + -- Add entity name. + if Is_Instance or Parent_Inst = null then + Prepend (Rstr, + To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name); + end if; + + if Parent_Inst = null then + -- Top reached. + Prepend (Rstr, Sep); + return; + else + -- Instantiation statement label. + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, + To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name); + Prepend (Rstr, Sep); + end if; + end; + when Ghdl_Rtik_For_Generate => + declare + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + end; + when others => + Internal_Error ("grt.rtis_utils.get_path_name"); + end case; + end loop; + end Get_Path_Name; + + procedure Put (Stream : FILEs; Ctxt : Rti_Context) + is + Rstr : Rstring; + begin + Get_Path_Name (Rstr, Ctxt, '.'); + Put (Stream, Rstr); + Free (Rstr); + end Put; + +end Grt.Rtis_Utils; diff --git a/src/translate/grt/grt-rtis_utils.ads b/src/translate/grt/grt-rtis_utils.ads new file mode 100644 index 0000000..10c1a0f --- /dev/null +++ b/src/translate/grt/grt-rtis_utils.ads @@ -0,0 +1,92 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- 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 Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Vstrings; use Grt.Vstrings; +with Grt.Stdio; use Grt.Stdio; + +package Grt.Rtis_Utils is + -- Action to perform after a node was handled by the user function: + -- Traverse_Ok: continue to process. + -- Traverse_Skip: do not traverse children. + -- Traverse_Stop: end of walk. + type Traverse_Result is (Traverse_Ok, Traverse_Skip, Traverse_Stop); + + -- An RTI object is a context and an RTI declaration. + type Rti_Object is record + Obj : Ghdl_Rti_Access; + Ctxt : Rti_Context; + end record; + + -- Traverse all blocks (package, entities, architectures, block, generate, + -- processes). + generic + with function Process (Ctxt : Rti_Context; + Obj : Ghdl_Rti_Access) + return Traverse_Result; + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result; + + generic + type Param_Type is private; + with procedure Process (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param : Param_Type); + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type); + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get the name of a physical unit. + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String; + + -- Get the value of a physical unit. + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64; + + -- Disp a value. + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access); + + -- Get context as a path name. + -- If IS_INSTANCE is true, the architecture name of entities is added. + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True); + + -- Disp a context as a path. + procedure Put (Stream : FILEs; Ctxt : Rti_Context); +end Grt.Rtis_Utils; diff --git a/src/translate/grt/grt-sdf.adb b/src/translate/grt/grt-sdf.adb new file mode 100644 index 0000000..73534e3 --- /dev/null +++ b/src/translate/grt/grt-sdf.adb @@ -0,0 +1,1389 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- 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.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Ada.Characters.Latin_1; +with Ada.Unchecked_Deallocation; +with Grt.Vital_Annotate; + +package body Grt.Sdf is + EOT : constant Character := Character'Val (4); + + type Sdf_Token_Type is + ( + Tok_Oparen, -- ( + Tok_Cparen, -- ) + Tok_Qstring, + Tok_Identifier, + Tok_Rnumber, + Tok_Dnumber, + Tok_Div, -- / + Tok_Dot, -- . + Tok_Cln, -- : + + Tok_Error, + Tok_Eof + ); + + type Sdf_Context_Acc is access Sdf_Context_Type; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => Sdf_Context_Acc, Object => Sdf_Context_Type); + + Sdf_Context : Sdf_Context_Acc; + + -- Current data read from the file. + Buf : String_Access (1 .. Buf_Size) := null; + + -- Length of the buffer, including the EOT. + Buf_Len : Natural; + Pos : Natural; + Line_Start : Integer; + + Sdf_Stream : FILEs := NULL_Stream; + Sdf_Filename : String_Access := null; + Sdf_Line : Natural; + + function Open_Sdf (Filename : String) return Boolean + is + N_Filename : String (1 .. Filename'Length + 1); + Mode : constant String := "rt" & NUL; + begin + N_Filename (1 .. Filename'Length) := Filename; + N_Filename (N_Filename'Last) := NUL; + Sdf_Stream := fopen (N_Filename'Address, Mode'Address); + if Sdf_Stream = NULL_Stream then + Error_C ("cannot open SDF file '"); + Error_C (Filename); + Error_E ("'"); + return False; + end if; + Sdf_Context := new Sdf_Context_Type; + + Sdf_Context.Version := Sdf_Version_Unknown; + + -- Set the timescale to 1 ns. + Sdf_Context.Timescale := 1000; + + Buf := new String (1 .. Buf_Size); + Buf_Len := 1; + Buf (1) := EOT; + Sdf_Line := 1; + Sdf_Filename := new String'(Filename); + Pos := 1; + Line_Start := 1; + return True; + end Open_Sdf; + + procedure Close_Sdf + is + begin + fclose (Sdf_Stream); + Sdf_Stream := NULL_Stream; + Unchecked_Deallocation (Sdf_Context); + Unchecked_Deallocation (Buf); + end Close_Sdf; + + procedure Read_Sdf + is + Res : size_t; + begin + Res := fread (Buf (Pos)'Address, 1, size_t (Read_Size), Sdf_Stream); + Line_Start := Line_Start - Buf_Len + Pos; + Buf_Len := Pos + Natural (Res); + Buf (Buf_Len) := EOT; + end Read_Sdf; + + + Ident_Start : Natural; + Ident_End : Natural; + + procedure Read_Append + is + Len : Natural; + begin + Len := Pos - Ident_Start; + if Ident_Start = 1 or Len >= 1024 then + Error_C ("SDF line "); + Error_C (Sdf_Line); + Error_E (" is too long"); + return; + end if; + Buf (1 .. Len) := Buf (Ident_Start .. Ident_Start + Len - 1); + Pos := Len + 1; + Ident_Start := 1; + Read_Sdf; + end Read_Append; + + procedure Error_Sdf_C is + begin + Error_C (Sdf_Filename.all); + Error_C (":"); + Error_C (Sdf_Line); + Error_C (":"); + Error_C (Pos - Line_Start); + Error_C (": "); + end Error_Sdf_C; + + procedure Error_Sdf (Msg : String) is + begin + Error_Sdf_C; + Error_E (Msg); + end Error_Sdf; + + procedure Error_Bad_Character is + begin + Error_Sdf ("bad character in SDF file"); + end Error_Bad_Character; + + procedure Scan_Identifier + is + begin + Ident_Start := Pos; + loop + Pos := Pos + 1; + case Buf (Pos) is + when 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '_' => + null; + when '\' => + Error_Sdf ("escape character not handled"); + Ident_End := Pos - 1; + return; + when EOT => + Read_Append; + Pos := Pos - 1; + when others => + Ident_End := Pos - 1; + return; + end case; + end loop; + end Scan_Identifier; + + function Ident_Length return Natural is + begin + return Ident_End - Ident_Start + 1; + end Ident_Length; + + function Is_Ident (Str : String) return Boolean + is + begin + if Ident_Length /= Str'Length then + return False; + end if; + return Buf (Ident_Start .. Ident_End) = Str; + end Is_Ident; + + procedure Scan_Qstring + is + begin + Ident_Start := Pos + 1; + loop + Pos := Pos + 1; + case Buf (Pos) is + when EOT => + Read_Append; + when NUL .. Character'Val (3) + | Character'Val (5) .. Character'Val (31) + | Character'Val (127) .. Character'Val (255) => + Error_Bad_Character; + when ' ' + | '!' + | '#' .. '~' => + null; + when '"' => -- " + Ident_End := Pos - 1; + Pos := Pos + 1; + exit; + end case; + end loop; + end Scan_Qstring; + + Scan_Int : Integer; + Scan_Exp : Integer; + + function Scan_Number return Sdf_Token_Type + is + Has_Dot : Boolean; + begin + Has_Dot := False; + Scan_Int := 0; + Scan_Exp := 0; + loop + case Buf (Pos) is + when '0' .. '9' => + Scan_Int := Scan_Int * 10 + + Character'Pos (Buf (Pos)) - Character'Pos ('0'); + if Has_Dot then + Scan_Exp := Scan_Exp - 1; + end if; + Pos := Pos + 1; + when '.' => + if Has_Dot then + Error_Bad_Character; + return Tok_Error; + else + Has_Dot := True; + end if; + Pos := Pos + 1; + when EOT => + if Pos /= Buf_Len then + Error_Bad_Character; + return Tok_Error; + end if; + Pos := 1; + Read_Sdf; + exit when Buf_Len = 1; + when others => + exit; + end case; + end loop; + if Has_Dot then + return Tok_Rnumber; + else + return Tok_Dnumber; + end if; + end Scan_Number; + + procedure Refill_Buf is + begin + Buf (1 .. Buf_Len - Pos) := Buf (Pos .. Buf_Len - 1); + Pos := Buf_Len - Pos + 1; + Read_Sdf; + Pos := 1; + end Refill_Buf; + + procedure Skip_Spaces + is + use Ada.Characters.Latin_1; + begin + -- Fast blanks skipping. + while Buf (Pos) = ' ' loop + Pos := Pos + 1; + end loop; + + loop + -- Be sure there is at least 1 character. + if Pos + 1 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Pos /= Buf_Len then + return; + end if; + Pos := 1; + Read_Sdf; + if Buf_Len = 1 then + return; + end if; + when LF => + Pos := Pos + 1; + if Buf (Pos) = CR then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when CR => + Pos := Pos + 1; + if Buf (Pos) = LF then + Pos := Pos + 1; + end if; + Line_Start := Pos; + Sdf_Line := Sdf_Line + 1; + when ' ' + | HT => + Pos := Pos + 1; + when '/' => + if Buf (Pos + 1) = '/' then + Pos := Pos + 2; + -- Skip line comment. + loop + exit when Buf (Pos) = CR; + exit when Buf (Pos) = LF; + exit when Buf (Pos) = EOT; + Pos := Pos + 1; + if Pos >= Buf_Len then + Refill_Buf; + end if; + end loop; + else + return; + end if; + when others => + return; + end case; + end loop; + end Skip_Spaces; + + function Get_Token return Sdf_Token_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when EOT => + if Buf_Len = 1 then + return Tok_Eof; + else + Error_Bad_Character; + return Tok_Error; + end if; + when '"' => -- " + Scan_Qstring; + return Tok_Qstring; + when '/' => + -- Skip_Spaces has already handled line comments. + Pos := Pos + 1; + return Tok_Div; + when '.' => + Pos := Pos + 1; + return Tok_Dot; + when ':' => + Pos := Pos + 1; + return Tok_Cln; + when '(' => + Pos := Pos + 1; + return Tok_Oparen; + when ')' => + Pos := Pos + 1; + return Tok_Cparen; + when 'a' .. 'z' + | 'A' .. 'Z' => + Scan_Identifier; + return Tok_Identifier; + when '0' .. '9' => + return Scan_Number; + when others => + Error_Bad_Character; + return Tok_Error; + end case; + end Get_Token; + + function Is_White_Space (C : Character) return Boolean + is + use Ada.Characters.Latin_1; + begin + case C is + when ' ' + | HT + | CR + | LF => + return True; + when others => + return False; + end case; + end Is_White_Space; + + function Get_Edge_Token return Edge_Type + is + use Ada.Characters.Latin_1; + begin + Skip_Spaces; + + -- Be sure there is at least 4 characters. + if Pos + 4 >= Buf_Len then + Refill_Buf; + end if; + + case Buf (Pos) is + when '0' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_0z; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_01; + end if; + end if; + when '1' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = 'z' then + Pos := Pos + 2; + return Edge_1z; + elsif Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_10; + end if; + end if; + when 'z' => + if Is_White_Space (Buf (Pos + 2)) then + if Buf (Pos + 1) = '0' then + Pos := Pos + 2; + return Edge_Z0; + elsif Buf (Pos + 1) = '1' then + Pos := Pos + 2; + return Edge_Z1; + end if; + end if; + when 'p' => + Scan_Identifier; + if Is_Ident ("posedge") then + return Edge_Posedge; + end if; + when 'n' => + Scan_Identifier; + if Is_Ident ("negedge") then + return Edge_Negedge; + end if; + when others => + null; + end case; + Error_Sdf ("edge_identifier expected"); + return Edge_Error; + end Get_Edge_Token; + + procedure Error_Sdf (Tok : Sdf_Token_Type) + is + begin + case Tok is + when Tok_Qstring => + Error_Sdf ("qstring expected"); + when Tok_Oparen => + Error_Sdf ("'(' expected"); + when Tok_Identifier => + Error_Sdf ("identifier expected"); + when Tok_Cln => + Error_Sdf ("':' (colon) expected"); + when others => + Error_Sdf ("parse error"); + end case; + end Error_Sdf; + + function Expect (Tok : Sdf_Token_Type) return Boolean + is + begin + if Get_Token = Tok then + return True; + end if; + Error_Sdf (Tok); + return False; + end Expect; + + function Expect_Cp_Op_Ident (Tok : Sdf_Token_Type) return Boolean + is + begin + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + return False; + end if; + return True; + end Expect_Cp_Op_Ident; + + function Expect_Qstr_Cp_Op_Ident (Str : String) return Boolean + is + Tok : Sdf_Token_Type; + begin + if not Is_Ident (Str) then + return True; + end if; + + Tok := Get_Token; + if Tok = Tok_Qstring then + Tok := Get_Token; + end if; + + return Expect_Cp_Op_Ident (Tok); + end Expect_Qstr_Cp_Op_Ident; + + procedure Start_Generic_Name (Kind : Timing_Generic_Kind) is + begin + Sdf_Context.Kind := Kind; + Sdf_Context.Port_Num := 0; + Sdf_Context.Ports (1).L := Invalid_Dnumber; + Sdf_Context.Ports (2).L := Invalid_Dnumber; + Sdf_Context.Ports (1).Edge := Edge_None; + Sdf_Context.Ports (2).Edge := Edge_None; + end Start_Generic_Name; + + -- Status of a parsing. + -- ERROR: parse error (syntax is not correct) + -- ALTERN: alternate construct parsed (ie simple RNUMBER for tc_rvalue). + -- OPTIONAL: the construct is absent. + -- FOUND: the construct is present. + -- SET: the construct is present and a value was extracted from. + type Parse_Status_Type is + ( + Status_Error, + Status_Altern, + Status_Optional, + Status_Found, + Status_Set + ); + + function Num_To_Time return Ghdl_I64 + is + Res : Ghdl_I64; + begin + Res := Ghdl_I64 (Scan_Int) * Ghdl_I64 (Sdf_Context.Timescale); + while Scan_Exp < 0 loop + Res := Res / 10; + Scan_Exp := Scan_Exp + 1; + end loop; + return Res; + end Num_To_Time; + + -- Parse: REXPRESSION? ')' + procedure Parse_Rexpression + (Status : out Parse_Status_Type; Val : out Ghdl_I64) + is + Tok : Sdf_Token_Type; + + procedure Pr_Rnumber (Mtm : Mtm_Type) + is + begin + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Mtm = Sdf_Mtm then + Val := Num_To_Time; + Status := Status_Set; + elsif Status /= Status_Set then + Status := Status_Found; + end if; + Tok := Get_Token; + end if; + end Pr_Rnumber; + + function Pr_Colon return Boolean + is + begin + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + Status := Status_Error; + return False; + else + Tok := Get_Token; + return True; + end if; + end Pr_Colon; + + begin + Val := 0; + Tok := Get_Token; + Status := Status_Error; + if Tok = Tok_Cparen then + Status := Status_Optional; + return; + end if; + + Pr_Rnumber (Minimum); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Typical); + + if not Pr_Colon then + return; + end if; + + Pr_Rnumber (Maximum); + + if Status = Status_Error then + Error_Sdf ("at least one number required in an rexpression"); + return; + end if; + + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + Status := Status_Error; + end if; + end Parse_Rexpression; + + function Expect_Rexpr_Cp_Op_Ident return Boolean + is + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + if Status = Status_Error then + return False; + end if; + if not Expect (Tok_Oparen) + or else not Expect (Tok_Identifier) + then + Error_Sdf (Tok_Identifier); + return False; + end if; + return True; + end Expect_Rexpr_Cp_Op_Ident; + + function To_Lower (C : Character) return Character is + begin + if C >= 'A' and C <= 'Z' then + return Character'Val (Character'Pos (C) + - Character'Pos ('A') + Character'Pos ('a')); + else + return C; + end if; + end To_Lower; + + function Parse_Port_Path1 (Tok : Sdf_Token_Type) return Boolean + is + Port_Spec : Port_Spec_Type + renames Sdf_Context.Ports (Sdf_Context.Port_Num); + Len : Natural; + begin + if Tok /= Tok_Identifier then + Error_Sdf ("port path expected"); + return False; + end if; + Len := 0; + for I in Ident_Start .. Ident_End loop + Len := Len + 1; + Port_Spec.Name (Len) := To_Lower (Buf (I)); + end loop; + Port_Spec.Name_Len := Len; + + -- Parse [ DNUMBER ] + -- | [ DNUMBER : DNUMBER ] + Skip_Spaces; + if Buf (Pos) = '[' then + Port_Spec.R := Invalid_Dnumber; + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.L := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + if Buf (Pos) = ':' then + Pos := Pos + 1; + if Get_Token /= Tok_Dnumber then + Error_Sdf (Tok); + else + Port_Spec.R := Ghdl_I32 (Scan_Int); + end if; + Skip_Spaces; + end if; + if Buf (Pos) /= ']' then + Error_Sdf ("']' expected"); + else + Pos := Pos + 1; + end if; + end if; + + return True; + end Parse_Port_Path1; + + function Parse_Port_Path return Boolean + is + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + return Parse_Port_Path1 (Get_Token); + end Parse_Port_Path; + + function Parse_Port_Spec return Boolean + is + Tok : Sdf_Token_Type; + Edge : Edge_Type; + begin + Sdf_Context.Port_Num := Sdf_Context.Port_Num + 1; + Tok := Get_Token; + if Tok = Tok_Identifier then + return Parse_Port_Path1 (Tok); + elsif Tok /= Tok_Oparen then + Error_Sdf ("port spec expected"); + return False; + end if; + Edge := Get_Edge_Token; + if Edge = Edge_Error then + return False; + end if; + Sdf_Context.Ports (Sdf_Context.Port_Num).Edge := Edge; + if not Parse_Port_Path1 (Get_Token) then + return False; + end if; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + return True; + end Parse_Port_Spec; + + function Parse_Port_Tchk return Boolean renames Parse_Port_Spec; + + -- tc_rvalue ::= ( RNUMBER ) + -- ||= ( rexpression ) + -- Return status_optional for ( ) + function Parse_Tc_Rvalue return Parse_Status_Type + is + Tok : Sdf_Token_Type; + Res : Parse_Status_Type; + begin + -- '(' + if Get_Token /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return Status_Error; + end if; + Res := Status_Found; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + Sdf_Context.Timing (1) := Num_To_Time; + Tok := Get_Token; + if Tok = Tok_Cparen then + -- This is a simple RNUMBER. + return Status_Altern; + end if; + if Sdf_Mtm = Minimum then + Res := Status_Set; + end if; + end if; + if Tok = Tok_Cparen then + return Status_Optional; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Typical then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cln then + Error_Sdf (Tok_Cln); + return Status_Error; + end if; + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Sdf_Mtm = Maximum then + Sdf_Context.Timing (1) := Num_To_Time; + Res := Status_Set; + end if; + Tok := Get_Token; + end if; + if Tok /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return Status_Error; + end if; + return Res; + end Parse_Tc_Rvalue; + + function Parse_Simple_Tc_Rvalue return Boolean is + begin + Sdf_Context.Timing_Nbr := 0; + + case Parse_Tc_Rvalue is + when Status_Error + | Status_Optional => + return False; + when Status_Altern => + null; + when Status_Found => + Sdf_Context.Timing_Set (1) := False; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + return True; + end Parse_Simple_Tc_Rvalue; + + -- rvalue ::= ( RNUMBER ) + -- ||= rexp_list + -- Parse: rvalue ) + function Parse_Rvalue return Boolean + is + Tok : Sdf_Token_Type; + begin + Sdf_Context.Timing_Nbr := 0; + Sdf_Context.Timing_Set := (others => False); + + case Parse_Tc_Rvalue is + when Status_Error => + return False; + when Status_Altern => + Sdf_Context.Timing_Nbr := 1; + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + end if; + return True; + when Status_Found + | Status_Optional => + null; + when Status_Set => + Sdf_Context.Timing_Set (1) := True; + end case; + + Sdf_Context.Timing_Nbr := 1; + loop + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + + Sdf_Context.Timing_Nbr := Sdf_Context.Timing_Nbr + 1; + declare + Status : Parse_Status_Type; + Val : Ghdl_I64; + begin + Parse_Rexpression (Status, Val); + case Status is + when Status_Error + | Status_Altern => + return False; + when Status_Optional + | Status_Found => + null; + when Status_Set => + Sdf_Context.Timing_Set (Sdf_Context.Timing_Nbr) := True; + Sdf_Context.Timing (Sdf_Context.Timing_Nbr) := Val; + end case; + end; + end loop; + if Boolean'(False) then + -- Do not expand here, since the most used is 01. + case Sdf_Context.Timing_Nbr is + when 1 => + for I in 2 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + when 2 => + for I in 3 .. 4 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (1); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (1); + end loop; + for I in 5 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (2); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (2); + end loop; + when 3 => + for I in 4 .. 6 loop + Sdf_Context.Timing (I) := Sdf_Context.Timing (I - 3); + Sdf_Context.Timing_Set (I) := Sdf_Context.Timing_Set (I - 3); + end loop; + when 6 + | 12 => + null; + when others => + Error_Sdf ("bad number of rvalue"); + return False; + end case; + end if; + return True; + end Parse_Rvalue; + + function Handle_Generic return Boolean + is + Name : String (1 .. 1024); + Len : Natural; + + procedure Start (Str : String) is + begin + Name (1 .. Str'Length) := Str; + Len := Str'Length; + end Start; + + procedure Add (Str : String) + is + Nlen : Natural; + begin + Len := Len + 1; + Name (Len) := '_'; + Nlen := Len + Str'Length; + Name (Len + 1 .. Nlen) := Str; + Len := Nlen; + end Add; + + procedure Add_Edge (Edge : Edge_Type; Force : Boolean) is + begin + case Edge is + when Edge_Posedge => + Add ("posedge"); + when Edge_Negedge => + Add ("negedge"); + when Edge_01 => + Add ("01"); + when Edge_10 => + Add ("10"); + when Edge_0z => + Add ("0z"); + when Edge_Z1 => + Add ("Z1"); + when Edge_1z => + Add ("1z"); + when Edge_Z0 => + Add ("ZO"); + when Edge_None => + if Force then + Add ("noedge"); + end if; + when Edge_Error => + Add ("?"); + end case; + end Add_Edge; + + Ok : Boolean; + begin + case Sdf_Context.Kind is + when Delay_Iopath => + Start ("tpd"); + when Delay_Port => + Start ("tipd"); + when Timingcheck_Setup => + Start ("tsetup"); + when Timingcheck_Hold => + Start ("thold"); + when Timingcheck_Setuphold => + Start ("tsetup"); + when Timingcheck_Recovery => + Start ("trecovery"); + when Timingcheck_Skew => + Start ("tskew"); + when Timingcheck_Width => + Start ("tpw"); + when Timingcheck_Period => + Start ("tperiod"); + when Timingcheck_Nochange => + Start ("tncsetup"); + end case; + for I in 1 .. Sdf_Context.Port_Num loop + Add (Sdf_Context.Ports (I).Name + (1 .. Sdf_Context.Ports (I).Name_Len)); + end loop; + if Sdf_Context.Kind in Timing_Generic_Full_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, True); + Add_Edge (Sdf_Context.Ports (2).Edge, False); + elsif Sdf_Context.Kind in Timing_Generic_Simple_Condition then + Add_Edge (Sdf_Context.Ports (1).Edge, False); + end if; + Vital_Annotate.Sdf_Generic (Sdf_Context.all, Name (1 .. Len), Ok); + if not Ok then + Error_Sdf_C; + Error_C ("could not annotate generic "); + Error_E (Name (1 .. Len)); + return False; + end if; + return True; + end Handle_Generic; + + function Parse_Sdf return Boolean + is + Tok : Sdf_Token_Type; + Ok : Boolean; + begin + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("DELAYFILE") + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("not an SDF file"); + return False; + end if; + + if Is_Ident ("SDFVERSION") then + Tok := Get_Token; + if Tok = Tok_Qstring then + Sdf_Context.Version := Sdf_Version_Bad; + if Ident_Length = 3 and then Buf (Ident_Start + 1) = '.' then + -- Version has the format '"X.Y"' (without simple quote). + if Buf (Ident_Start) = '2' + and then Buf (Ident_Start + 2) = '1' + then + Sdf_Context.Version := Sdf_2_1; + end if; + end if; + Tok := Get_Token; + end if; + + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DESIGN") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("DATE") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VENDOR") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROGRAM") then + return False; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("VERSION") then + return False; + end if; + + if Is_Ident ("DIVIDER") then + Tok := Get_Token; + if Tok = Tok_Div or Tok = Tok_Dot then + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + if Is_Ident ("VOLTAGE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if not Expect_Qstr_Cp_Op_Ident ("PROCESS") then + return False; + end if; + + if Is_Ident ("TEMPERATURE") then + if not Expect_Rexpr_Cp_Op_Ident then + return False; + end if; + end if; + + if Is_Ident ("TIMESCALE") then + Tok := Get_Token; + if Tok = Tok_Rnumber or Tok = Tok_Dnumber then + if Scan_Exp = 0 and (Scan_Int = 1 + or Scan_Int = 10 + or Scan_Int = 100) + then + Sdf_Context.Timescale := Scan_Int; + else + Error_Sdf ("bad timescale value"); + return False; + end if; + Tok := Get_Token; + if Tok /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + end if; + if Is_Ident ("ps") then + null; + elsif Is_Ident ("ns") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000; + elsif Is_Ident ("us") then + Sdf_Context.Timescale := Sdf_Context.Timescale * 1000_000; + else + Error_Sdf ("bad timescale unit"); + return False; + end if; + Tok := Get_Token; + end if; + if not Expect_Cp_Op_Ident (Tok) then + return False; + end if; + end if; + + Vital_Annotate.Sdf_Header (Sdf_Context.all); + + -- Parse cell+ + loop + if not Is_Ident ("CELL") then + Error_Sdf ("CELL expected"); + return False; + end if; + -- Parse celltype + if Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("CELLTYPE") + or else Get_Token /= Tok_Qstring + then + Error_Sdf ("CELLTYPE expected"); + return False; + end if; + Sdf_Context.Celltype_Len := Ident_Length; + if Sdf_Context.Celltype_Len > Sdf_Context.Celltype'Length then + Error_Sdf ("CELLTYPE qstring is too long"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Sdf_Context.Celltype (I - Ident_Start + 1) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Celltype (Sdf_Context.all); + if Get_Token /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + or else not Is_Ident ("INSTANCE") + then + Error_Sdf ("INSTANCE expected"); + return False; + end if; + -- Parse instance+ + loop + exit when not Is_Ident ("INSTANCE"); + Tok := Get_Token; + if Tok /= Tok_Cparen then + loop + if Tok /= Tok_Identifier then + Error_Sdf ("instance identifier expected"); + return False; + end if; + for I in Ident_Start .. Ident_End loop + Buf (I) := To_Lower (Buf (I)); + end loop; + Vital_Annotate.Sdf_Instance + (Sdf_Context.all, Buf (Ident_Start .. Ident_End), Ok); + if not Ok then + Error_Sdf ("cannot find instance"); + return False; + end if; + Tok := Get_Token; + exit when Tok /= Tok_Dot; + Tok := Get_Token; + end loop; + end if; + if Tok /= Tok_Cparen + or else Get_Token /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("instance or timing_spec expected"); + return False; + end if; + end loop; + Vital_Annotate.Sdf_Instance_End (Sdf_Context.all, Ok); + if not Ok then + Error_Sdf ("bad instance or celltype mistmatch"); + return False; + end if; + + -- Parse timing_spec+ + loop + if Is_Ident ("DELAY") then + -- Parse deltype+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("deltype expected"); + return False; + end if; + if Is_Ident ("PATHPULSE") + or else Is_Ident ("GLOBALPATHPULSE") + then + Error_Sdf ("PATHPULSE and GLOBALPATHPULSE not allowed"); + return False; + end if; + if Is_Ident ("ABSOLUTE") then + null; + elsif Is_Ident ("INCREMENT") then + null; + else + Error_Sdf ("ABSOLUTE or INCREMENT expected"); + return False; + end if; + -- Parse absvals+ or incvals+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + if Is_Ident ("IOPATH") then + Start_Generic_Name (Delay_Iopath); + if not Parse_Port_Spec + or else not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("PORT") then + Start_Generic_Name (Delay_Port); + if not Parse_Port_Path + or else not Parse_Rvalue + then + return False; + end if; + elsif Is_Ident ("COND") + or else Is_Ident ("INTERCONNECT") + or else Is_Ident ("DEVICE") + then + Error_Sdf + ("COND, INTERCONNECT, or DEVICE not handled"); + return False; + elsif Is_Ident ("NETDELAY") then + Error_Sdf ("NETDELAY not allowed in VITAL SDF"); + return False; + else + Error_Sdf ("absvals or incvals expected"); + return False; + end if; + + if not Handle_Generic then + return False; + end if; + + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + elsif Is_Ident ("TIMINGCHECK") then + -- parse tc_def+ + Tok := Get_Token; + loop + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf ("tc_def expected"); + return False; + end if; + if Is_Ident ("SETUP") then + Start_Generic_Name (Timingcheck_Setup); + elsif Is_Ident ("HOLD") then + Start_Generic_Name (Timingcheck_Hold); + elsif Is_Ident ("SETUPHOLD") then + Start_Generic_Name (Timingcheck_Setuphold); + elsif Is_Ident ("RECOVERY") then + Start_Generic_Name (Timingcheck_Recovery); + elsif Is_Ident ("SKEW") then + Start_Generic_Name (Timingcheck_Skew); + elsif Is_Ident ("WIDTH") then + Start_Generic_Name (Timingcheck_Width); + elsif Is_Ident ("PERIOD") then + Start_Generic_Name (Timingcheck_Period); + elsif Is_Ident ("NOCHANGE") then + Start_Generic_Name (Timingcheck_Nochange); + elsif Is_Ident ("PATHCONSTRAINT") + or else Is_Ident ("SUM") + or else Is_Ident ("DIFF") + or else Is_Ident ("SKEWCONSTRAINT") + then + Error_Sdf ("non-VITAL tc_def"); + return False; + else + Error_Sdf ("bad tc_def"); + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setup + | Timingcheck_Hold + | Timingcheck_Recovery + | Timingcheck_Skew + | Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Port_Tchk + or else not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when Timingcheck_Width + | Timingcheck_Period => + if not Parse_Port_Tchk + or else not Parse_Simple_Tc_Rvalue + then + return False; + end if; + when others => + Internal_Error ("sdf_parse"); + end case; + + if not Handle_Generic then + return False; + end if; + + case Sdf_Context.Kind is + when Timingcheck_Setuphold + | Timingcheck_Nochange => + if not Parse_Simple_Tc_Rvalue then + return False; + end if; + Error_Sdf ("setuphold and nochange not yet handled"); + return False; + when others => + null; + end case; + + if Get_Token /= Tok_Cparen then + Error_Sdf (Tok_Cparen); + return False; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + end loop; + end if; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen then + Error_Sdf (Tok_Oparen); + return False; + end if; + if Get_Token /= Tok_Identifier then + Error_Sdf (Tok_Identifier); + return False; + end if; + end loop; + Tok := Get_Token; + exit when Tok = Tok_Cparen; + if Tok /= Tok_Oparen + or else Get_Token /= Tok_Identifier + then + Error_Sdf (Tok_Identifier); + end if; + end loop; + if Get_Token /= Tok_Eof then + Error_Sdf ("EOF expected"); + return False; + end if; + return True; + end Parse_Sdf; + + function Parse_Sdf_File (Filename : String) return Boolean + is + Res : Boolean; + begin + if not Open_Sdf (Filename) then + return False; + end if; + Res := Parse_Sdf; + Close_Sdf; + return Res; + end Parse_Sdf_File; + +end Grt.Sdf; diff --git a/src/translate/grt/grt-sdf.ads b/src/translate/grt/grt-sdf.ads new file mode 100644 index 0000000..fd05b9e --- /dev/null +++ b/src/translate/grt/grt-sdf.ads @@ -0,0 +1,131 @@ +-- GHDL Run Time (GRT) - SDF parser. +-- 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.Types; use Grt.Types; + +package Grt.Sdf is + type Edge_Type is + ( + Edge_Error, + Edge_None, + Edge_Posedge, + Edge_Negedge, + Edge_01, + Edge_10, + Edge_0z, + Edge_Z1, + Edge_1z, + Edge_Z0 + ); + + type Timing_Generic_Kind is + ( + Delay_Port, + --Delay_Interconnect, + --Delay_Device, + + -- Simple condition + Delay_Iopath, + Timingcheck_Width, + Timingcheck_Period, + + -- Full condition + Timingcheck_Setup, + Timingcheck_Hold, + Timingcheck_Recovery, + Timingcheck_Skew, + Timingcheck_Nochange, + Timingcheck_Setuphold + ); + + subtype Timing_Generic_Simple_Condition is Timing_Generic_Kind + range Delay_Iopath .. Timingcheck_Period; + + subtype Timing_Generic_Full_Condition is Timing_Generic_Kind + range Timingcheck_Setup .. Timingcheck_Setuphold; + + type Sdf_Version_Type is + ( + Sdf_2_1, + Sdf_Version_Unknown, + Sdf_Version_Bad + ); + + Read_Size : constant Natural := 4096; + Buf_Size : constant Natural := Read_Size + 1024 + 1; + + Invalid_Dnumber : constant Ghdl_I32 := -1; + + type Port_Spec_Type is record + -- Port identifier. + Name : String (1 .. 128); + Name_Len : Natural; + + -- Left and Right range. + -- If L = R = Invalid_Dnumber, this is a simple scalar port. + -- If R = Invalid_Dnumber, this is a scalar port (from a vector) + -- Otherwise, this is a bus port. + L, R : Ghdl_I32; + + -- Cond : String (1 .. 1024); + -- Cond_Len : Natural; + + Edge : Edge_Type; + end record; + + type Port_Spec_Array_Type is array (Natural range <>) of Port_Spec_Type; + + type Ghdl_I64_Array is array (1 .. 12) of Ghdl_I64; + type Boolean_Array is array (1 .. 12) of Boolean; + + type Sdf_Context_Type is record + -- Version of the SDF file. + Version : Sdf_Version_Type; + + -- Timescale; 1 corresponds to 1 ps. + -- Default is 1000 (1 ns). + Timescale : Natural; + + Kind : Timing_Generic_Kind; + + -- Cell type. + Celltype : String (1 .. 128); + Celltype_Len : Natural; + + -- Current port. + Port_Num : Natural; + Ports : Port_Spec_Array_Type (1 .. 2); + + -- timing spec. + Timing : Ghdl_I64_Array; + Timing_Set : Boolean_Array; + Timing_Nbr : Natural; + end record; + + -- Which value is extracted. + type Mtm_Type is (Minimum, Typical, Maximum); + Sdf_Mtm : Mtm_Type := Typical; + + function Parse_Sdf_File (Filename : String) return Boolean; +end Grt.Sdf; diff --git a/src/translate/grt/grt-shadow_ieee.adb b/src/translate/grt/grt-shadow_ieee.adb new file mode 100644 index 0000000..32af4be --- /dev/null +++ b/src/translate/grt/grt-shadow_ieee.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- 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.Shadow_Ieee is + procedure Ieee_Std_Logic_1164_Resolved_RESOLV is + begin + Internal_Error ("resolved_RESOLV from shadow ieee called"); + end Ieee_Std_Logic_1164_Resolved_RESOLV; +end Grt.Shadow_Ieee; diff --git a/src/translate/grt/grt-shadow_ieee.ads b/src/translate/grt/grt-shadow_ieee.ads new file mode 100644 index 0000000..f12b479 --- /dev/null +++ b/src/translate/grt/grt-shadow_ieee.ads @@ -0,0 +1,41 @@ +-- GHDL Run Time (GRT) - ghost declarations for ieee. +-- 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. + +-- This packages provides dummy declaration for main IEEE.STD_LOGIC_1164 +-- type descriptors. +-- The package must not have elaboration code, since the actual type +-- descriptors are not writable (they are constant). Making it preelaborated +-- is not enough, the variables must be initialized. This current +-- implementation provides bad values; this is not a problem since they are +-- not read in grt. + +package Grt.Shadow_Ieee is + pragma Preelaborate (Grt.Shadow_Ieee); + + procedure Ieee_Std_Logic_1164_Resolved_RESOLV; +private + pragma Export (C, Ieee_Std_Logic_1164_Resolved_RESOLV, + "ieee__std_logic_1164__resolved_RESOLV"); +end Grt.Shadow_Ieee; diff --git a/src/translate/grt/grt-signals.adb b/src/translate/grt/grt-signals.adb new file mode 100644 index 0000000..9698d81 --- /dev/null +++ b/src/translate/grt/grt-signals.adb @@ -0,0 +1,3400 @@ +-- GHDL Run Time (GRT) - signals management. +-- 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 System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Processes; use Grt.Processes; +with Grt.Options; use Grt.Options; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Disp_Signals; +with Grt.Astdio; +with Grt.Stdio; +with Grt.Threads; use Grt.Threads; + +package body Grt.Signals is + procedure Free is new Ada.Unchecked_Deallocation + (Object => Transaction, Name => Transaction_Acc); + + procedure Free_In (Trans : Transaction_Acc) + is + Ntrans : Transaction_Acc; + begin + Ntrans := Trans; + Free (Ntrans); + end Free_In; + pragma Inline (Free_In); + + -- RTI for the current signal. + Sig_Rti : Ghdl_Rtin_Object_Acc; + + -- Signal mode (and flags) for the current signal. + Sig_Mode : Mode_Signal_Type; + Sig_Has_Active : Boolean; + Sig_Kind : Kind_Signal_Type; + + -- Last created implicit signal. This is used to add dependencies on + -- the prefix. + Last_Implicit_Signal : Ghdl_Signal_Ptr; + + -- Current signal resolver. + Current_Resolv : Resolved_Signal_Acc := null; + + function Get_Current_Mode_Signal return Mode_Signal_Type is + begin + return Sig_Mode; + end Get_Current_Mode_Signal; + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : Address) + is + pragma Unreferenced (Ctxt); + pragma Unreferenced (Addr); + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc (Sig); + Sig_Mode := Mode_Signal_Type'Val + (Sig.Mode and Ghdl_Rti_Signal_Mode_Mask); + Sig_Kind := Kind_Signal_Type'Val + ((Sig.Mode and Ghdl_Rti_Signal_Kind_Mask) + / Ghdl_Rti_Signal_Kind_Offset); + Sig_Has_Active := + (Sig_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0; + end Ghdl_Signal_Name_Rti; + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean) is + begin + Sig_Rti := null; + Sig_Mode := Mode; + Sig_Kind := Kind; + Sig_Has_Active := Has_Active; + end Ghdl_Signal_Set_Mode; + + function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is + begin + return Sig.Sig_Kind /= Kind_Signal_No; + end Is_Signal_Guarded; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Ghdl_Signal_Ptr, Target => Address); + + function Create_Signal + (Mode : Mode_Type; + Init_Val : Value_Union; + Mode_Sig : Mode_Signal_Type; + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Data (Mode_Sig); + begin + Sig_Table.Increment_Last; + + if Current_Resolv = null then + if Resolv_Proc /= null then + Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Resolv_Proc, + Resolv_Inst => Resolv_Inst, + Resolv_Ptr => Null_Address, + Sig_Range => (Sig_Table.Last, Sig_Table.Last), + Disconnect_Time => Bad_Time); + else + Resolv := null; + end if; + else + if Resolv_Proc /= null then + -- Only one resolution function is allowed! + Internal_Error ("create_signal"); + end if; + Resolv := Current_Resolv; + if Current_Resolv.Sig_Range.Last = Sig_Table.Last then + Current_Resolv := null; + end if; + end if; + + case Mode_Sig is + when Mode_Signal_User => + S.Nbr_Drivers := 0; + S.Drivers := null; + S.Effective := null; + S.Resolv := Resolv; + when Mode_Conv_In + | Mode_Conv_Out => + S.Conv := null; + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + S.Time := 0; + when Mode_Guard => + S.Guard_Func := null; + S.Guard_Instance := System.Null_Address; + when Mode_Transaction + | Mode_End => + null; + end case; + + Res := new Ghdl_Signal'(Value => Init_Val, + Driving_Value => Init_Val, + Last_Value => Init_Val, + -- Note: use -Std_Time'last instead of + -- Std_Time'First so that NOW - x'last_event + -- returns time'high at initialization! + Last_Event => -Std_Time'Last, + Last_Active => -Std_Time'Last, + Event => False, + Active => False, + Has_Active => False, + Sig_Kind => Sig_Kind, + + Is_Direct_Active => False, + Mode => Mode, + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => Sig_Rti, + + Nbr_Ports => 0, + Ports => null, + + S => S); + + if Resolv /= null and then Resolv.Resolv_Ptr = System.Null_Address then + Resolv.Resolv_Ptr := To_Address (Res); + end if; + + case Flag_Activity is + when Activity_All => + Res.Has_Active := True; + when Activity_Minimal => + Res.Has_Active := Sig_Has_Active; + when Activity_None => + Res.Has_Active := False; + end case; + + -- Put the signal in the table. + Sig_Table.Table (Sig_Table.Last) := Res; + + return Res; + end Create_Signal; + + procedure Ghdl_Signal_Init (Sig : Ghdl_Signal_Ptr; Val : Value_Union) is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + Sig.Last_Value := Val; + end Ghdl_Signal_Init; + + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access) + is + S_Rti : Ghdl_Rtin_Object_Acc; + begin + S_Rti := To_Ghdl_Rtin_Object_Acc (Rti); + if Flag_Activity = Activity_Minimal then + if (S_Rti.Common.Mode and Ghdl_Rti_Signal_Has_Active) /= 0 then + Sig.Has_Active := True; + end if; + end if; + end Ghdl_Signal_Merge_Rti; + + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type) + is + begin + if Current_Resolv /= null then + Internal_Error ("Ghdl_Signal_Create_Resolution"); + end if; + Current_Resolv := new Resolved_Signal_Type' + (Resolv_Proc => Proc, + Resolv_Inst => Instance, + Resolv_Ptr => Sig, + Sig_Range => (First => Sig_Table.Last + 1, + Last => Sig_Table.Last + Sig_Table_Index (Nbr_Sig)), + Disconnect_Time => Bad_Time); + end Ghdl_Signal_Create_Resolution; + + procedure Check_New_Source (Sig : Ghdl_Signal_Ptr) + is + use Grt.Stdio; + use Grt.Astdio; + begin + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + if Sig.S.Resolv = null then + -- LRM 4.3.1.2 Signal Declaration + -- It is an error if, after the elaboration of a description, a + -- signal has multiple sources and it is not a resolved signal. + if Sig.Rti /= null then + Put ("for signal: "); + Disp_Signals.Put_Signal_Name (stderr, Sig); + New_Line (stderr); + end if; + Error ("several sources for unresolved signal"); + elsif Sig.S.Mode_Sig = Mode_Buffer and False then + -- LRM 1.1.1.2 Ports + -- A BUFFER port may have at most one source. + + -- FIXME: this is not true with VHDL-02. + -- With VHDL-87/93, should also check that: any actual associated + -- with a formal buffer port may have at most one source. + Error ("buffer port which more than one source"); + end if; + end if; + end Check_New_Source; + + -- Return TRUE if already present. + function Ghdl_Signal_Add_Driver (Sign : Ghdl_Signal_Ptr; + Trans : Transaction_Acc) + return Boolean + is + type Size_T is mod 2**Standard'Address_Size; + + function Malloc (Size : Size_T) return Driver_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Driver_Arr_Ptr; Size : Size_T) + return Driver_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Driver_Fat_Array'Component_Size + / System.Storage_Unit); + end Size; + + Proc : Process_Acc; + begin + Proc := Get_Current_Process; + if Sign.S.Nbr_Drivers = 0 then + Check_New_Source (Sign); + Sign.S.Drivers := Malloc (Size (1)); + Sign.S.Nbr_Drivers := 1; + else + -- Do not create a driver twice. + for I in 0 .. Sign.S.Nbr_Drivers - 1 loop + if Sign.S.Drivers (I).Proc = Proc then + return True; + end if; + end loop; + Check_New_Source (Sign); + Sign.S.Nbr_Drivers := Sign.S.Nbr_Drivers + 1; + Sign.S.Drivers := Realloc (Sign.S.Drivers, Size (Sign.S.Nbr_Drivers)); + end if; + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1) := + (First_Trans => Trans, + Last_Trans => Trans, + Proc => Proc); + return False; + end Ghdl_Signal_Add_Driver; + + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + end if; + end Ghdl_Process_Add_Driver; + + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr) + is + Trans : Transaction_Acc; + Trans1 : Transaction_Acc; + begin + -- Create transaction for current driving value. + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Sign.Value); + if Ghdl_Signal_Add_Driver (Sign, Trans) then + Free (Trans); + return; + end if; + -- Create transaction for the next driving value. + Trans1 := new Transaction'(Kind => Trans_Direct, + Line => 0, + Time => 0, + Next => null, + Val_Ptr => Drv); + Sign.S.Drivers (Sign.S.Nbr_Drivers - 1).Last_Trans := Trans1; + Trans.Next := Trans1; + end Ghdl_Signal_Add_Direct_Driver; + + procedure Append_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + type Size_T is new Integer; + + function Malloc (Size : Size_T) return Signal_Arr_Ptr; + pragma Import (C, Malloc); + + function Realloc (Ptr : Signal_Arr_Ptr; Size : Size_T) + return Signal_Arr_Ptr; + pragma Import (C, Realloc); + + function Size (N : Ghdl_Index_Type) return Size_T is + begin + return Size_T (N * Ghdl_Signal_Ptr'Size / System.Storage_Unit); + end Size; + begin + if Targ.Nbr_Ports = 0 then + Targ.Ports := Malloc (Size (1)); + Targ.Nbr_Ports := 1; + else + Targ.Nbr_Ports := Targ.Nbr_Ports + 1; + Targ.Ports := Realloc (Targ.Ports, Size (Targ.Nbr_Ports)); + end if; + Targ.Ports (Targ.Nbr_Ports - 1) := Src; + end Append_Port; + + -- Add SRC to port list of TARG, but only if not already in this list. + procedure Add_Port (Targ : Ghdl_Signal_Ptr; Src : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Targ.Nbr_Ports loop + if Targ.Ports (I - 1) = Src then + return; + end if; + end loop; + Append_Port (Targ, Src); + end Add_Port; + + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + Check_New_Source (Targ); + Append_Port (Targ, Src); + end Ghdl_Signal_Add_Source; + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time) is + begin + if Sign.S.Resolv = null then + Internal_Error ("ghdl_signal_set_disconnect: not resolved"); + end if; + if Sign.S.Resolv.Disconnect_Time /= Bad_Time then + Error ("disconnection already specified for signal"); + end if; + if Time < 0 then + Error ("disconnection time is negative"); + end if; + Sign.S.Resolv.Disconnect_Time := Time; + end Ghdl_Signal_Set_Disconnect; + + procedure Direct_Assign + (Targ : out Value_Union; Val : Ghdl_Value_Ptr; Mode : Mode_Type) + is + begin + case Mode is + when Mode_B1 => + Targ.B1 := Val.B1; + when Mode_E8 => + Targ.E8 := Val.E8; + when Mode_E32 => + Targ.E32 := Val.E32; + when Mode_I32 => + Targ.I32 := Val.I32; + when Mode_I64 => + Targ.I64 := Val.I64; + when Mode_F64 => + Targ.F64 := Val.F64; + end case; + end Direct_Assign; + + function Value_Equal (Left, Right : Value_Union; Mode : Mode_Type) + return Boolean + is + begin + case Mode is + when Mode_B1 => + return Left.B1 = Right.B1; + when Mode_E8 => + return Left.E8 = Right.E8; + when Mode_E32 => + return Left.E32 = Right.E32; + when Mode_I32 => + return Left.I32 = Right.I32; + when Mode_I64 => + return Left.I64 = Right.I64; + when Mode_F64 => + return Left.F64 = Right.F64; + end case; + end Value_Equal; + + procedure Error_Trans_Error (Trans : Transaction_Acc) is + begin + Error_C ("range check error on signal at "); + Error_C (Trans.File); + Error_C (":"); + Error_C (Natural (Trans.Line)); + Error_E (""); + end Error_Trans_Error; + pragma No_Return (Error_Trans_Error); + + function Find_Driver (Sig : Ghdl_Signal_Ptr) return Ghdl_Index_Type + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + Error ("assignment to a signal without any driver"); + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return I; + end if; + end loop; + Error ("assignment to a signal without a driver for the process"); + end Find_Driver; + + function Get_Driver (Sig : Ghdl_Signal_Ptr) return Driver_Acc + is + Proc : Process_Acc; + begin + if Sig.S.Drivers = null then + return null; + end if; + Proc := Get_Current_Process; + for I in 0 .. Sig.S.Nbr_Drivers - 1 loop + if Sig.S.Drivers (I).Proc = Proc then + return Sig.S.Drivers (I)'Access; + end if; + end loop; + return null; + end Get_Driver; + + -- Return TRUE iff SIG has a future transaction for the current time, + -- ie iff SIG will be active in the next delta cycle. This is used to + -- recompute wether SIG must be in the active chain. SIG must be a user + -- signal. + function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr) + return Boolean is + begin + if Sig.Is_Direct_Active then + return True; + end if; + + for I in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : constant Transaction_Acc := + Sig.S.Drivers (I - 1).First_Trans.Next; + begin + if Trans.Kind /= Trans_Direct + and then Trans.Time = Current_Time + then + return True; + end if; + end; + end loop; + return False; + end Has_Transaction_In_Next_Delta; + + -- Unused but well-known signal which always terminate + -- ghdl_signal_active_chain. + -- As a consequence, every element of the chain has a link field set to + -- a non-null value (this is of course not true for SIGNAL_END). This may + -- be used to quickly check if a signal is in the list. + -- This signal is not in the signal table. + Signal_End : Ghdl_Signal_Ptr; + + -- List of signals which have projected waveforms in the future (beyond + -- the next delta cycle). + Future_List : aliased Ghdl_Signal_Ptr; + + procedure Ghdl_Signal_Start_Assign (Sign : Ghdl_Signal_Ptr; + Reject : Std_Time; + Trans : Transaction_Acc; + After : Std_Time) + is + Assign_Time : Std_Time; + Drv : constant Ghdl_Index_Type := Find_Driver (Sign); + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Drv); + begin + -- LRM93 8.4.1 + -- It is an error if the time expression in a waveform element + -- evaluates to a negative value. + if After < 0 then + Error ("negative time expression in signal assignment"); + end if; + + if After = 0 then + -- Put SIGN on the active list if the transaction is scheduled + -- for the next delta cycle. + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + else + -- AFTER > 0. + -- Put SIGN on the future list. + if Sign.Flink = null then + Sign.Flink := Grt.Threads.Atomic_Insert (Future_List'access, Sign); + end if; + end if; + + Assign_Time := Current_Time + After; + if Assign_Time < 0 then + -- Beyond the future + Free_In (Trans); + return; + end if; + + -- Handle sign as direct driver. + if Driver.Last_Trans.Kind = Trans_Direct then + if After /= 0 then + Internal_Error ("direct assign with non-0 after"); + end if; + -- FIXME: can be a bound-error too! + if Trans.Kind = Trans_Value then + case Sign.Mode is + when Mode_B1 => + Driver.Last_Trans.Val_Ptr.B1 := Trans.Val.B1; + when Mode_E8 => + Driver.Last_Trans.Val_Ptr.E8 := Trans.Val.E8; + when Mode_E32 => + Driver.Last_Trans.Val_Ptr.E32 := Trans.Val.E32; + when Mode_I32 => + Driver.Last_Trans.Val_Ptr.I32 := Trans.Val.I32; + when Mode_I64 => + Driver.Last_Trans.Val_Ptr.I64 := Trans.Val.I64; + when Mode_F64 => + Driver.Last_Trans.Val_Ptr.F64 := Trans.Val.F64; + end case; + Free_In (Trans); + elsif Trans.Kind = Trans_Error then + Error_Trans_Error (Trans); + else + Internal_Error ("direct assign with non-value"); + end if; + return; + end if; + + -- LRM93 8.4.1 + -- 1. All old transactions that are projected to occur at or after the + -- time at which the earliest new transaction is projected to occur + -- are deleted from the projected output waveform. + if Driver.Last_Trans.Time >= Assign_Time then + declare + -- LAST is the last transaction to keep. + Last : Transaction_Acc; + Next : Transaction_Acc; + begin + Last := Driver.First_Trans; + -- Find the first transaction to be deleted. + Next := Last.Next; + while Next /= null and then Next.Time < Assign_Time loop + Last := Next; + Next := Next.Next; + end loop; + -- Delete old transactions. + if Next /= null then + -- Set the last transaction of the driver. + Driver.Last_Trans := Last; + -- Cut the chain. This is not strickly necessary, since + -- it will be overriden below, by appending TRANS to the + -- driver. + Last.Next := null; + -- Free removed transactions. + loop + Last := Next.Next; + Free (Next); + exit when Last = null; + Next := Last; + end loop; + end if; + end; + end if; + + -- 2. The new transaction are then appended to the projected output + -- waveform in the order of their projected occurence. + Trans.Time := Assign_Time; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + + -- If the initial delay is inertial delay according to the definitions + -- of section 8.4, the projected output waveform is further modified + -- as follows: + -- 1. All of the new transactions are marked. + -- 2. An old transaction is marked if the time at which it is projected + -- to occur is less than the time at which the first new transaction + -- is projected to occur minus the pulse rejection limit. + -- 3. For each remaining unmarked, old transaction, the old transaction + -- is marked if it immediatly precedes a marked transaction and its + -- value component is the same as that of the marked transaction; + -- 4. The transaction that determines the current value of the driver + -- is marked. + -- 5. All unmarked transactions (all of which are old transactions) are + -- deleted from the projected output waveform. + -- + -- GHDL: only transactions that are projected to occur at [T-R, T[ + -- can be deleted (R is the reject time, T is now + after time). + if Reject > 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is [...] or greater than the + -- time expression associated with the first waveform element. + if Reject > After then + Error ("pulse rejection greater than first waveform delay"); + end if; + + declare + Prev : Transaction_Acc; + Next : Transaction_Acc; + begin + -- Find the first transaction after the project time less the + -- rejection time. + -- PREV will be the last old transaction which is projected to + -- occur before T - R. + Prev := Driver.First_Trans; + loop + Next := Prev.Next; + exit when Next.Time >= Assign_Time - Reject; + Prev := Next; + end loop; + + -- Scan every transaction until TRANS. If a transaction value is + -- different from the TRANS value, then delete all previous + -- transactions (from T - R to the currently scanned transaction), + -- since they are not marked. + while Next /= Trans loop + if Next.Kind /= Trans.Kind + or else + (Trans.Kind = Trans_Value + and then not Value_Equal (Next.Val, Trans.Val, Sign.Mode)) + then + -- NEXT is different from TRANS. + -- Delete ]PREV;NEXT]. + declare + D, N : Transaction_Acc; + begin + D := Prev.Next; + Next := Next.Next; + Prev.Next := Next; + loop + N := D.Next; + Free (D); + exit when N = Next; + D := N; + end loop; + end; + else + Next := Next.Next; + end if; + end loop; + + -- A previous assignment (with a 0 after time) may have put this + -- signal on the active chain. But maybe this previous + -- transaction has been removed (due to rejection) and therefore + -- this signal won't be active at the next delta. So remove it + -- from the active chain. This is a little bit costly (because + -- the chain is simply linked), but that issue doesn't appear + -- frequently. + if Sign.Link /= null + and then not Has_Transaction_In_Next_Delta (Sign) + then + if Ghdl_Signal_Active_Chain = Sign then + -- At the head of the chain. + -- FIXME: this is not atomic. + Ghdl_Signal_Active_Chain := Sign.Link; + else + -- In the middle of the chain. + declare + Prev : Ghdl_Signal_Ptr := Ghdl_Signal_Active_Chain; + begin + while Prev.Link /= Sign loop + Prev := Prev.Link; + end loop; + Prev.Link := Sign.Link; + end; + end if; + Sign.Link := null; + end if; + end; + elsif Reject /= 0 then + -- LRM93 8.4 + -- It is an error if the pulse rejection limit for any inertially + -- delayed signal assignment statement is either negative or [...]. + Error ("pulse rejection is negative"); + end if; + + -- Do some checks. + if Driver.Last_Trans.Next /= null then + Error ("ghdl_signal_start_assign internal_error"); + end if; + end Ghdl_Signal_Start_Assign; + + procedure Ghdl_Signal_Next_Assign (Sign : Ghdl_Signal_Ptr; + Val : Value_Union; + After : Std_Time) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + After, + Next => null, + Val => Val); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign; + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr) is + begin + if Sign.Link = null then + Sign.Link := Grt.Threads.Atomic_Insert + (Ghdl_Signal_Active_Chain'access, Sign); + end if; + + -- Must be always set (as Sign.Link may be set by a regular driver). + Sign.Is_Direct_Active := True; + end Ghdl_Signal_Direct_Assign; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => 0, + Next => null, + File => File); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Error; + + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32) + is + Drv_Ptr : constant Driver_Arr_Ptr := Sign.S.Drivers; + Driver : Driver_Type renames Drv_Ptr (Find_Driver (Sign)); + + Trans : Transaction_Acc; + begin + if After > 0 and then Sign.Flink = null then + -- Put SIGN on the future list. + Sign.Flink := Future_List; + Future_List := Sign; + end if; + + Trans := new Transaction'(Kind => Trans_Error, + Line => Line, + Time => Current_Time + After, + Next => null, + File => File); + if Trans.Time <= Driver.Last_Trans.Time then + Error ("transactions not in ascending order"); + end if; + Driver.Last_Trans.Next := Trans; + Driver.Last_Trans := Trans; + end Ghdl_Signal_Next_Assign_Error; + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_Null; + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr) + is + Trans : Transaction_Acc; + Time : Std_Time; + begin + if not Is_Signal_Guarded (Sign) then + Error ("null transaction for a non-guarded target"); + end if; + Trans := new Transaction'(Kind => Trans_Null, + Line => 0, + Time => 0, + Next => null); + Time := Sign.S.Resolv.Disconnect_Time; + Ghdl_Signal_Start_Assign (Sign, Time, Trans, Time); + end Ghdl_Signal_Disconnect; + + procedure Ghdl_Signal_Associate (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + begin + Sig.Value := Val; + Sig.Driving_Value := Val; + end Ghdl_Signal_Associate; + + function Ghdl_Create_Signal_B1 + (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_B1; + + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_B1, B1 => Init_Val)); + end Ghdl_Signal_Init_B1; + + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_B1, B1 => Val)); + end Ghdl_Signal_Associate_B1; + + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.B1 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_B1; + + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_B1; + + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_B1, B1 => Val), After); + end Ghdl_Signal_Next_Assign_B1; + + function Ghdl_Create_Signal_E8 + (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E8, Value_Union'(Mode => Mode_E8, E8 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E8; + + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8) is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E8, E8 => Init_Val)); + end Ghdl_Signal_Init_E8; + + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8) is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E8, E8 => Val)); + end Ghdl_Signal_Associate_E8; + + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E8 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E8; + + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E8, E8 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E8; + + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E8, E8 => Val), After); + end Ghdl_Signal_Next_Assign_E8; + + function Ghdl_Create_Signal_E32 + (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_E32, Value_Union'(Mode => Mode_E32, E32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_E32; + + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_E32, E32 => Init_Val)); + end Ghdl_Signal_Init_E32; + + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_E32, E32 => Val)); + end Ghdl_Signal_Associate_E32; + + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.E32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_E32; + + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_E32, E32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_E32; + + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_E32, E32 => Val), After); + end Ghdl_Signal_Next_Assign_E32; + + function Ghdl_Create_Signal_I32 + (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I32, Value_Union'(Mode => Mode_I32, I32 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I32; + + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I32, I32 => Init_Val)); + end Ghdl_Signal_Init_I32; + + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I32, I32 => Val)); + end Ghdl_Signal_Associate_I32; + + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I32 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I32; + + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I32, I32 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I32; + + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I32, I32 => Val), After); + end Ghdl_Signal_Next_Assign_I32; + + function Ghdl_Create_Signal_I64 + (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_I64, Value_Union'(Mode => Mode_I64, I64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_I64; + + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_I64, I64 => Init_Val)); + end Ghdl_Signal_Init_I64; + + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_I64, I64 => Val)); + end Ghdl_Signal_Associate_I64; + + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.I64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_I64; + + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_I64, I64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_I64; + + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_I64, I64 => Val), After); + end Ghdl_Signal_Next_Assign_I64; + + function Ghdl_Create_Signal_F64 + (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr + is + begin + return Create_Signal + (Mode_F64, Value_Union'(Mode => Mode_F64, F64 => Init_Val), + Get_Current_Mode_Signal, + Resolv_Func, Resolv_Inst); + end Ghdl_Create_Signal_F64; + + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64) + is + begin + Ghdl_Signal_Init (Sig, Value_Union'(Mode => Mode_F64, F64 => Init_Val)); + end Ghdl_Signal_Init_F64; + + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64) + is + begin + Ghdl_Signal_Associate (Sig, Value_Union'(Mode => Mode_F64, F64 => Val)); + end Ghdl_Signal_Associate_F64; + + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64) + is + Trans : Transaction_Acc; + begin + if not Sign.Has_Active + and then Sign.Net = Net_One_Driver + and then Val = Sign.Value.F64 + and then Sign.S.Drivers (0).First_Trans.Next = null + then + return; + end if; + + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + + Ghdl_Signal_Start_Assign (Sign, 0, Trans, 0); + end Ghdl_Signal_Simple_Assign_F64; + + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time) + is + Trans : Transaction_Acc; + begin + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Value_Union'(Mode => Mode_F64, F64 => Val)); + Ghdl_Signal_Start_Assign (Sign, Rej, Trans, After); + end Ghdl_Signal_Start_Assign_F64; + + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time) + is + begin + Ghdl_Signal_Next_Assign + (Sign, Value_Union'(Mode => Mode_F64, F64 => Val), After); + end Ghdl_Signal_Next_Assign_F64; + + procedure Ghdl_Signal_Internal_Checks + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- Check drivers. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Drivers (J - 1).First_Trans; + while Trans.Next /= null loop + if Trans.Next.Time < Trans.Time then + Internal_Error ("ghdl_signal_internal_checks: " + & "bad transaction order"); + end if; + Trans := Trans.Next; + end loop; + if Trans /= Sig.S.Drivers (J - 1).Last_Trans then + Internal_Error ("ghdl_signal_internal_checks: " + & "last transaction mismatch"); + end if; + end; + end loop; + when others => + null; + end case; + end loop; + end Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr) + is + begin + if Targ.S.Effective /= null then + Error ("internal error: already effective value"); + end if; + Targ.S.Effective := Src; + end Ghdl_Signal_Effective_Value; + + Bit_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + Boolean_Signal_Rti : aliased Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => null); + + function Ghdl_Create_Signal_Attribute + (Mode : Mode_Signal_Type; Time : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; +-- Sig_Type : Ghdl_Desc_Ptr; + begin + case Mode is + when Mode_Transaction => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Bit_Signal_Rti'Address)); + when Mode_Quiet + | Mode_Stable => + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Boolean_Signal_Rti'Address)); + when others => + Internal_Error ("ghdl_create_signal_attribute"); + end case; + -- Note: bit and boolean are both mode_b1. + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => True), + Mode, null, Null_Address); + Sig_Rti := null; + Last_Implicit_Signal := Res; + + if Mode /= Mode_Transaction then + Res.S.Time := Time; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + end if; + + if Time > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + + return Res; + end Ghdl_Create_Signal_Attribute; + + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Stable, Val); + end Ghdl_Create_Stable_Signal; + + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Quiet, Val); + end Ghdl_Create_Quiet_Signal; + + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr + is + begin + return Ghdl_Create_Signal_Attribute (Mode_Transaction, 0); + end Ghdl_Create_Transaction_Signal; + + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + end Ghdl_Signal_Attribute_Register_Prefix; + + --Guard_String : constant String := "guard"; + --Guard_Name : constant Ghdl_Str_Len_Address_Type := + -- (Len => 5, Str => Guard_String'Address); + --function To_Ghdl_Str_Len_Ptr is new Ada.Unchecked_Conversion + -- (Source => System.Address, Target => Ghdl_Str_Len_Ptr); + + Guard_Rti : aliased constant Ghdl_Rtin_Object := + (Common => (Kind => Ghdl_Rtik_Signal, + Depth => 0, + Mode => Ghdl_Rti_Signal_Mode_None, + Max_Depth => 0), + Name => null, + Loc => Null_Rti_Loc, + Obj_Type => Std_Standard_Boolean_RTI_Ptr); + + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Sig_Rti := To_Ghdl_Rtin_Object_Acc + (To_Ghdl_Rti_Access (Guard_Rti'Address)); + Res := Create_Signal + (Mode_B1, Value_Union'(Mode => Mode_B1, B1 => Proc.all (This)), + Mode_Guard, null, Null_Address); + Sig_Rti := null; + Res.S.Guard_Func := Proc; + Res.S.Guard_Instance := This; + Last_Implicit_Signal := Res; + return Res; + end Ghdl_Signal_Create_Guard; + + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr) + is + begin + Add_Port (Last_Implicit_Signal, Sig); + Sig.Has_Active := True; + end Ghdl_Signal_Guard_Dependence; + + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr + is + Res : Ghdl_Signal_Ptr; + begin + Res := Create_Signal (Sig.Mode, Sig.Value, + Mode_Delayed, null, Null_Address); + Res.S.Time := Val; + if Val > 0 then + Res.Flink := Future_List; + Future_List := Res; + end if; + Res.S.Attr_Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => 0, + Next => null, + Val => Res.Value); + Append_Port (Res, Sig); + return Res; + end Ghdl_Create_Delayed_Signal; + + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index + is + begin + -- Note: we may start from ptr.instance_name.sig_index, but + -- instance_name is *not* set for conversion signals. + for I in reverse Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I) = Ptr then + return I; + end if; + end loop; + return -1; + end Signal_Ptr_To_Index; + + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.Nbr_Ports; + end Ghdl_Signal_Get_Nbr_Ports; + + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type is + begin + return Sig.S.Nbr_Drivers; + end Ghdl_Signal_Get_Nbr_Drivers; + + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + begin + if Index >= Sig.Nbr_Ports then + Internal_Error ("ghdl_signal_read_port: bad index"); + end if; + return To_Ghdl_Value_Ptr (Sig.Ports (Index).Driving_Value'Address); + end Ghdl_Signal_Read_Port; + + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr + is + Trans : Transaction_Acc; + begin + if Index >= Sig.S.Nbr_Drivers then + Internal_Error ("ghdl_signal_read_driver: bad index"); + end if; + Trans := Sig.S.Drivers (Index).First_Trans; + case Trans.Kind is + when Trans_Value => + return To_Ghdl_Value_Ptr (Trans.Val'Address); + when Trans_Direct => + Internal_Error ("ghdl_signal_read_driver: trans_direct"); + when Trans_Null => + return null; + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end Ghdl_Signal_Read_Driver; + + procedure Ghdl_Signal_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type; + Mode : Mode_Signal_Type) + is + Data : Sig_Conversion_Acc; + Sig : Ghdl_Signal_Ptr; + begin + Data := new Sig_Conversion_Type'(Func => Func, + Instance => Instance, + Src => (-1, -1), + Dest => (-1, -1)); + Data.Src.First := Signal_Ptr_To_Index (Src); + Data.Src.Last := Data.Src.First + Sig_Table_Index (Src_Len) - 1; + + Data.Dest.First := Signal_Ptr_To_Index (Dst); + Data.Dest.Last := Data.Dest.First + Sig_Table_Index (Dst_Len) - 1; + + -- Convert DEST to new mode. + for I in Data.Dest.First .. Data.Dest.Last loop + Sig := Sig_Table.Table (I); + case Mode is + when Mode_Conv_In => + Sig.S := (Mode_Sig => Mode_Conv_In, + Conv => Data); + when Mode_Conv_Out => + Sig.S := (Mode_Sig => Mode_Conv_Out, + Conv => Data); + when others => + Internal_Error ("ghdl_signal_conversion"); + end case; + end loop; + end Ghdl_Signal_Conversion; + + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_In); + end Ghdl_Signal_In_Conversion; + + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type) + is + begin + Ghdl_Signal_Conversion + (Func, Instance, Src, Src_Len, Dst, Dst_Len, Mode_Conv_Out); + end Ghdl_Signal_Out_Conversion; + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null then + -- FIXME: disp signal and process. + Error ("'driving error: no driver in process for signal"); + end if; + if Drv.First_Trans.Kind /= Trans_Null then + return True; + else + return False; + end if; + end Ghdl_Signal_Driving; + + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.B1; + end if; + end Ghdl_Signal_Driving_Value_B1; + + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E8; + end if; + end Ghdl_Signal_Driving_Value_E8; + + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.E32; + end if; + end Ghdl_Signal_Driving_Value_E32; + + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I32; + end if; + end Ghdl_Signal_Driving_Value_I32; + + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.I64; + end if; + end Ghdl_Signal_Driving_Value_I64; + + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64 + is + Drv : Driver_Acc; + begin + Drv := Get_Driver (Sig); + if Drv = null or else Drv.First_Trans.Kind /= Trans_Value then + Error ("'driving_value: no active driver in process for signal"); + else + return Drv.First_Trans.Val.F64; + end if; + end Ghdl_Signal_Driving_Value_F64; + + Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr; + + procedure Flush_Active_List + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + begin + -- Free active_chain. + Sig := Ghdl_Signal_Active_Chain; + loop + Next_Sig := Sig.Link; + exit when Next_Sig = null; + Sig.Link := null; + Sig := Next_Sig; + end loop; + Ghdl_Signal_Active_Chain := Sig; + end Flush_Active_List; + + function Find_Next_Time return Std_Time + is + Res : Std_Time; + Sig : Ghdl_Signal_Ptr; + + procedure Check_Transaction (Trans : Transaction_Acc) + is + begin + if Trans = null or else Trans.Kind = Trans_Direct then + -- Activity of direct drivers is done through link. + return; + end if; + + if Trans.Time = Res and Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + elsif Trans.Time < Res then + Flush_Active_List; + + -- Put sig on the list. + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + + Res := Trans.Time; + end if; + if Res = Current_Time then + -- Must have been in the active list. + Internal_Error ("find_next_time(2)"); + end if; + end Check_Transaction; + begin + -- If there is signals in the active list, then next cycle is a delta + -- cycle, so next time is current_time. + if Ghdl_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + if Ghdl_Implicit_Signal_Active_Chain.Link /= null then + return Current_Time; + end if; + Res := Std_Time'Last; + + Sig := Future_List; + while Sig.Flink /= null loop + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for J in 1 .. Sig.S.Nbr_Drivers loop + Check_Transaction (Sig.S.Drivers (J - 1).First_Trans.Next); + end loop; + when Mode_Delayed + | Mode_Stable + | Mode_Quiet => + Check_Transaction (Sig.S.Attr_Trans.Next); + when others => + Internal_Error ("find_next_time(3)"); + end case; + Sig := Sig.Flink; + end loop; + return Res; + end Find_Next_Time; + +-- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr) +-- return Natural +-- is +-- Length : Natural; +-- begin +-- Length := Sig.Nbr_Ports; +-- for I in 0 .. Sig.Nbr_Drivers - 1 loop +-- case Sig.Drivers (I).First_Trans.Kind is +-- when Trans_Value => +-- Length := Length + 1; +-- when Trans_Null => +-- null; +-- when Trans_Error => +-- Error ("range check error"); +-- end case; +-- end loop; +-- return Length; +-- end Get_Nbr_Non_Null_Source; + + function To_Resolver_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Resolver_Acc); + + procedure Compute_Resolved_Signal (Resolv : Resolved_Signal_Acc) + is + Sig : constant Ghdl_Signal_Ptr := + Sig_Table.Table (Resolv.Sig_Range.First); + Length : Ghdl_Index_Type; + type Bool_Array_Type is array (1 .. Sig.S.Nbr_Drivers) of Boolean; + Vec : Bool_Array_Type; + begin + -- Compute number of non-null drivers. + Length := 0; + for I in 1 .. Sig.S.Nbr_Drivers loop + case Sig.S.Drivers (I - 1).First_Trans.Kind is + when Trans_Value => + Length := Length + 1; + Vec (I) := True; + when Trans_Null => + Vec (I) := False; + when Trans_Error => + Error ("range check error"); + when Trans_Direct => + Internal_Error ("compute_resolved_signal: trans_direct"); + end case; + end loop; + + -- Check driving condition on all signals. + for J in Resolv.Sig_Range.First + 1.. Resolv.Sig_Range.Last loop + for I in 1 .. Sig.S.Nbr_Drivers loop + if (Sig_Table.Table (J).S.Drivers (I - 1).First_Trans.Kind + /= Trans_Null) + xor Vec (I) + then + Error ("null-transaction required"); + end if; + end loop; + end loop; + + -- if no driving sources and register, exit. + if Length = 0 + and then Sig.Nbr_Ports = 0 + and then Sig.Sig_Kind = Kind_Signal_Register + then + return; + end if; + + -- Call the procedure. + Resolv.Resolv_Proc.all (Resolv.Resolv_Inst, + Resolv.Resolv_Ptr, + Vec'Address, + Length, + Sig.S.Nbr_Drivers, + Sig.Nbr_Ports); + end Compute_Resolved_Signal; + + procedure Call_Conversion_Function (Conv : Sig_Conversion_Acc) + is + F : Conversion_Func_Acc; + begin + F := To_Conversion_Func_Acc (Conv.Func); + F.all (Conv.Instance); + end Call_Conversion_Function; + + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc) + is + El : Action_List_Acc; + begin + El := new Action_List'(Dynamic => False, + Proc => Proc, + Next => Sig.Event_List); + Sig.Event_List := El; + end Resume_Process_If_Event; + + -- Order of signals: + -- To be computed: driving value or/and effective value + -- To be considered: ports, signals, implicit signals, resolution, + -- conversion + -- + + procedure Add_Propagation (P : Propagation_Type) is + begin + Propagation.Increment_Last; + Propagation.Table (Propagation.Last) := P; + end Add_Propagation; + + procedure Add_Forward_Propagation (Sig : Ghdl_Signal_Ptr) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Add_Propagation + ((Kind => Imp_Forward_Build, + Forward => new Forward_Build_Type'(Src => Sig.Ports (I - 1), + Targ => Sig))); + end loop; + end Add_Forward_Propagation; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag); + + -- Return TRUE is the effective value of SIG is the driving value of SIG. + function Is_Eff_Drv (Sig : Ghdl_Signal_Ptr) return Boolean + is + begin + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + return True; + when Mode_Linkage + | Mode_Out => + -- No effective value. + return False; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + if Sig.S.Nbr_Drivers > 0 or Sig.Nbr_Ports > 0 then + -- Only for inout. + return True; + else + return False; + end if; + else + return False; + end if; + when Mode_Conv_In + | Mode_Conv_Out => + return False; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + return True; + when Mode_End => + return False; + end case; + end Is_Eff_Drv; + + procedure Order_Signal_List (Sig : Ghdl_Signal_Ptr; + Order : Propag_Order_Flag) + is + begin + for I in 1 .. Sig.Nbr_Ports loop + Order_Signal (Sig.Ports (I - 1), Order); + end loop; + end Order_Signal_List; + + -- Put SIG in PROPAGATION table until ORDER level. + procedure Order_Signal (Sig : Ghdl_Signal_Ptr; Order : Propag_Order_Flag) + is + begin + if Sig = null then + return; + end if; + + -- Catch infinite loops, which must never happen. + -- Also exit if the signal is already fully ordered. + case Sig.Flags.Propag is + when Propag_None => + null; + when Propag_Being_Driving => + Internal_Error ("order_signal: being driving"); + when Propag_Being_Effective => + Internal_Error ("order_signal: being effective"); + when Propag_Driving => + null; + when Propag_Done => + -- If sig was already handled, nothing to do! + return; + end case; + + -- First, the driving value. + if Sig.Flags.Propag = Propag_None then + case Sig.S.Mode_Sig is + when Mode_Signal_User => + if Sig.S.Nbr_Drivers = 0 and Sig.Nbr_Ports = 0 then + -- No source. + Sig.Flags.Propag := Propag_Driving; + elsif Sig.S.Resolv = null then + -- Not resolved (so at most one source). + if Sig.S.Nbr_Drivers = 1 then + -- Not resolved, 1 source : a driver. + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Driver, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + else + Sig.Flags.Propag := Propag_Being_Driving; + -- not resolved, 1 source : Source is a port. + Order_Signal (Sig.Ports (0), Propag_Driving); + if Is_Eff_Drv (Sig) then + Add_Propagation ((Kind => Eff_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + else + Add_Propagation ((Kind => Drv_One_Port, Sig => Sig)); + Sig.Flags.Propag := Propag_Driving; + end if; + end if; + else + -- Resolved signal. + declare + Resolv : Resolved_Signal_Acc; + S : Ghdl_Signal_Ptr; + begin + -- Compute driving value of brothers. + Resolv := Sig.S.Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + if S.Flags.Propag /= Propag_None then + Internal_Error ("order_signal(1)"); + end if; + S.Flags.Propag := Propag_Being_Driving; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + -- Compute driving value of the sources. + for J in 1 .. S.Nbr_Ports loop + Order_Signal (S.Ports (J - 1), Propag_Driving); + end loop; + end loop; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + S := Sig_Table.Table (I); + S.Flags.Propag := Propag_Driving; + end loop; + + if Is_Eff_Drv (Sig) then + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Eff_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Eff_Multiple, + Resolv => Resolv)); + end if; + else + if Resolv.Sig_Range.First = Resolv.Sig_Range.Last then + Add_Propagation ((Kind => Drv_One_Resolved, + Sig => Sig)); + else + Add_Propagation ((Kind => Drv_Multiple, + Resolv => Resolv)); + end if; + end if; + end; + end if; + when Mode_Signal_Implicit => + Sig.Flags.Propag := Propag_Being_Driving; + Order_Signal_List (Sig, Propag_Done); + Sig.Flags.Propag := Propag_Done; + if Sig.S.Mode_Sig in Mode_Signal_Forward then + Add_Forward_Propagation (Sig); + end if; + case Mode_Signal_Implicit (Sig.S.Mode_Sig) is + when Mode_Guard => + Add_Propagation ((Kind => Imp_Guard, Sig => Sig)); + when Mode_Stable => + Add_Propagation ((Kind => Imp_Stable, Sig => Sig)); + when Mode_Quiet => + Add_Propagation ((Kind => Imp_Quiet, Sig => Sig)); + when Mode_Transaction => + Add_Propagation ((Kind => Imp_Transaction, Sig => Sig)); + when Mode_Delayed => + Add_Propagation ((Kind => Imp_Delayed, Sig => Sig)); + end case; + return; + when Mode_Conv_In => + -- In conversion signals have no driving value + null; + when Mode_Conv_Out => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Driving; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + Add_Propagation ((Kind => Out_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end if; + + -- Effective value. + if Order = Propag_Driving then + -- Will be done later. + return; + end if; + + case Sig.S.Mode_Sig is + when Mode_Signal + | Mode_Buffer => + -- Effective value is driving value. + Sig.Flags.Propag := Propag_Done; + when Mode_Linkage + | Mode_Out => + -- No effective value. + Sig.Flags.Propag := Propag_Done; + when Mode_Inout + | Mode_In => + if Sig.S.Effective = null then + -- Effective value is driving value or initial value. + null; + else + Sig.Flags.Propag := Propag_Being_Effective; + Order_Signal (Sig.S.Effective, Propag_Done); + Add_Propagation ((Kind => Eff_Actual, Sig => Sig)); + Sig.Flags.Propag := Propag_Done; + end if; + when Mode_Stable + | Mode_Guard + | Mode_Quiet + | Mode_Transaction + | Mode_Delayed => + -- Sig.Propag is already set to PROPAG_DONE. + null; + when Mode_Conv_In => + declare + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Being_Effective; + end loop; + for I in Conv.Src.First .. Conv.Src.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + Add_Propagation ((Kind => In_Conversion, Conv => Conv)); + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Flags.Propag := Propag_Done; + end loop; + end; + when Mode_Conv_Out => + -- No effective value. + null; + when Mode_End => + Internal_Error ("order_signal: mode_end"); + end case; + end Order_Signal; + + procedure Set_Net (Sig : Ghdl_Signal_Ptr; + Net : Signal_Net_Type; + Link : Ghdl_Signal_Ptr) + is + use Astdio; + use Stdio; + begin + if Sig = null then + return; + end if; + + if Boolean'(False) then + Put ("set_net "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + Put (" "); + Disp_Signals.Disp_Mode_Signal (Sig.S.Mode_Sig); + New_Line; + end if; + + if Sig.Net /= No_Signal_Net then + if Sig.Net /= Net then + -- Renumber. + if Boolean'(False) then + Put ("set_net renumber "); + Put_I32 (stdout, Ghdl_I32 (Net)); + Put (" on "); + Put (stdout, Sig.all'Address); + New_Line; + end if; + + declare + S : Ghdl_Signal_Ptr; + Old : constant Signal_Net_Type := Sig.Net; + begin + -- Merge the old net into NET. + S := Sig; + loop + S.Net := Net; + S := S.Link; + exit when S = Sig; + end loop; + + -- Add to the ring. + S := Sig.Link; + Sig.Link := Link.Link; + Link.Link := S; + + -- Check. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Net = Old then +-- Disp_Signals.Disp_Signals_Table; +-- Disp_Signals.Disp_Signals_Map; + + Internal_Error ("set_net: link corrupted"); + end if; + end loop; + end; + end if; + return; + end if; + + Sig.Net := Net; + + -- Add SIG in the LINK ring. + -- Note: this works even if LINK is not a ring (ie, LINK.link = null). + if Link.Link = null and then Sig /= Link then + Internal_Error ("set_net: bad link"); + end if; + Sig.Link := Link.Link; + Link.Link := Sig; + + -- Dependences. + case Sig.S.Mode_Sig is + when Mode_Signal_User => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + Set_Net (Sig.S.Effective, Net, Link); + if Sig.S.Resolv /= null then + for I in Sig.S.Resolv.Sig_Range.First + .. Sig.S.Resolv.Sig_Range.Last + loop + Set_Net (Sig_Table.Table (I), Net, Link); + end loop; + end if; + when Mode_Signal_Forward => + null; + when Mode_Transaction + | Mode_Guard => + for I in 1 .. Sig.Nbr_Ports loop + Set_Net (Sig.Ports (I - 1), Net, Link); + end loop; + when Mode_Conv_In + | Mode_Conv_Out => + declare + S : Ghdl_Signal_Ptr; + Conv : Sig_Conversion_Acc; + begin + Conv := Sig.S.Conv; + S := Sig_Table.Table (Conv.Src.First); + if Sig = S or else S.Net /= Net then + for J in Conv.Src.First .. Conv.Src.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + for J in Conv.Dest.First .. Conv.Dest.Last loop + Set_Net (Sig_Table.Table (J), Net, Link); + end loop; + end if; + end; + when Mode_End => + Internal_Error ("set_net"); + end case; + end Set_Net; + + function Get_Propagation_Net (P : Signal_Net_Type) return Signal_Net_Type + is + begin + case Propagation.Table (P).Kind is + when Drv_Multiple + | Eff_Multiple => + return Sig_Table.Table + (Propagation.Table (P).Resolv.Sig_Range.First).Net; + when In_Conversion + | Out_Conversion => + return Sig_Table.Table + (Propagation.Table (P).Conv.Src.First).Net; + when Imp_Forward_Build => + return Propagation.Table (P).Forward.Src.Net; + when others => + return Propagation.Table (P).Sig.Net; + end case; + end Get_Propagation_Net; + + Last_Signal_Net : Signal_Net_Type; + + -- Create a net for SIG, or if one of its dependences has already a net, + -- merge SIG in this net. + procedure Merge_Net (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Resolv = null + and then Sig.Nbr_Ports = 0 + and then Sig.S.Effective = null + then + Internal_Error ("merge_net(1)"); + end if; + + if Sig.S.Effective /= null + and then Sig.S.Effective.Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.S.Effective.Net, Sig.S.Effective); + return; + end if; + end if; + + if Sig.Nbr_Ports >= 1 + and then Sig.Ports (0).Net /= No_Signal_Net + then + -- Avoid to create a net, just merge. + Set_Net (Sig, Sig.Ports (0).Net, Sig.Ports (0)); + else + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + end Merge_Net; + + -- Create nets. + -- For all signals, set the net field. + procedure Create_Nets + is + Sig : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := No_Signal_Net; + + for I in reverse Propagation.First .. Propagation.Last loop + case Propagation.Table (I).Kind is + when Drv_Error + | Prop_End => + null; + when Drv_One_Driver + | Eff_One_Driver => + null; + when Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + -- Do not create a net if the signal has no dependences. + if Sig.Net = No_Signal_Net + and then (Sig.S.Effective /= null or Sig.Nbr_Ports /= 0) + then + Merge_Net (Sig); + end if; + when Drv_One_Port + | Eff_One_Port + | Imp_Guard + | Imp_Transaction + | Eff_Actual + | Drv_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + Merge_Net (Sig); + end if; + when Imp_Forward => + -- Should not yet appear. + Internal_Error ("create_nets - forward"); + when Imp_Forward_Build => + Sig := Propagation.Table (I).Forward.Src; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Sig, Last_Signal_Net, Sig); + end if; + when Imp_Quiet + | Imp_Stable + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Net = No_Signal_Net then + -- Create a new net with only sig. + Last_Signal_Net := Last_Signal_Net + 1; + Sig.Net := Last_Signal_Net; + Sig.Link := Sig; + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + Link : Ghdl_Signal_Ptr; + begin + Last_Signal_Net := Last_Signal_Net + 1; + Resolv := Propagation.Table (I).Resolv; + Link := Sig_Table.Table (Resolv.Sig_Range.First); + for J in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Set_Net (Sig_Table.Table (J), Last_Signal_Net, Link); + end loop; + end; + when In_Conversion + | Out_Conversion => + declare + Conv : Sig_Conversion_Acc; + Link : Ghdl_Signal_Ptr; + begin + Conv := Propagation.Table (I).Conv; + Link := Sig_Table.Table (Conv.Src.First); + if Link.Net = No_Signal_Net then + Last_Signal_Net := Last_Signal_Net + 1; + Set_Net (Link, Last_Signal_Net, Link); + end if; + end; + end case; + end loop; + + -- Reorder propagation table. + declare + type Off_Array is array (Signal_Net_Type range <>) of Signal_Net_Type; + Offs : Off_Array (0 .. Last_Signal_Net) := (others => 0); + + Last_Off : Signal_Net_Type; + Num : Signal_Net_Type; + +-- procedure Disp_Offs +-- is +-- use Grt.Astdio; +-- use Grt.Stdio; +-- begin +-- for I in Offs'Range loop +-- if Offs (I) /= 0 then +-- Put_I32 (stdout, Ghdl_I32 (I)); +-- Put (": "); +-- Put_I32 (stdout, Ghdl_I32 (Offs (I))); +-- New_Line; +-- end if; +-- end loop; +-- end Disp_Offs; + + type Propag_Array is array (Signal_Net_Type range <>) + of Propagation_Type; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Object => Forward_Build_Type, Name => Forward_Build_Acc); + + Net : Signal_Net_Type; + begin + -- 1) Count number of propagation cell per net. + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + Offs (Net) := Offs (Net) + 1; + end loop; + + -- 2) Convert numbers to offsets. + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + Num := Offs (I); + if Num /= 0 then + -- Reserve one slot for a prepended 'prop_end'. + Offs (I) := Last_Off + 1; + Last_Off := Last_Off + 1 + Num; + end if; + end loop; + Offs (0) := Last_Off + 1; + + declare + Propag : Propag_Array (1 .. Last_Off); -- := (others => 0); + begin + for I in Propagation.First .. Propagation.Last loop + Net := Get_Propagation_Net (I); + if Net /= No_Signal_Net then + Propag (Offs (Net)) := Propagation.Table (I); + Offs (Net) := Offs (Net) + 1; + end if; + end loop; + Propagation.Set_Last (Last_Off); + Propagation.Release; + for I in Propagation.First .. Propagation.Last loop + if Propag (I).Kind = Imp_Forward_Build then + Propagation.Table (I) := (Kind => Imp_Forward, + Sig => Propag (I).Forward.Targ); + Deallocate (Propag (I).Forward); + else + Propagation.Table (I) := Propag (I); + end if; + end loop; + end; + for I in 1 .. Last_Signal_Net loop + -- Ignore holes. + if Offs (I) /= 0 then + Propagation.Table (Offs (I)) := + (Kind => Prop_End, Updated => True); + end if; + end loop; + Propagation.Table (1) := (Kind => Prop_End, Updated => True); + + -- 4) Convert back from offset to start position (on the prop_end + -- cell). + Offs (0) := 1; + Last_Off := 1; + for I in 1 .. Last_Signal_Net loop + if Offs (I) /= 0 then + Num := Offs (I); + Offs (I) := Last_Off; + Last_Off := Num; + end if; + end loop; + + -- 5) Re-map the nets to cell indexes. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + if Sig.Net = No_Signal_Net then + if Sig.S.Resolv /= null then + Sig.Net := Net_One_Resolved; + elsif Sig.S.Nbr_Drivers = 1 then + if Sig.S.Drivers (0).Last_Trans.Kind = Trans_Direct then + Sig.Net := Net_One_Direct; + else + Sig.Net := Net_One_Driver; + end if; + end if; + else + Sig.Net := Offs (Sig.Net); + end if; + Sig.Link := null; + end loop; + end; + end Create_Nets; + + function Get_Nbr_Future return Ghdl_I32 + is + Res : Ghdl_I32; + Sig : Ghdl_Signal_Ptr; + begin + Res := 0; + Sig := Future_List; + while Sig.Flink /= null loop + Res := Res + 1; + Sig := Sig.Flink; + end loop; + return Res; + end Get_Nbr_Future; + + -- Check every scalar subelement of a resolved signal has a driver + -- in the same process. + procedure Check_Resolved_Driver (Resolv : Resolved_Signal_Acc) + is + First_Sig : Ghdl_Signal_Ptr; + Nbr : Ghdl_Index_Type; + begin + First_Sig := Sig_Table.Table (Resolv.Sig_Range.First); + Nbr := First_Sig.S.Nbr_Drivers; + for I in Resolv.Sig_Range.First + 1 .. Resolv.Sig_Range.Last loop + if Sig_Table.Table (I).S.Nbr_Drivers /= Nbr then + -- FIXME: provide more information (signal name, process name). + Error ("missing drivers for subelement of a resolved signal"); + end if; + end loop; + end Check_Resolved_Driver; + + Ieee_Std_Logic_1164_Resolved_Resolv_Ptr : Address; + pragma Import (C, Ieee_Std_Logic_1164_Resolved_Resolv_Ptr, + "ieee__std_logic_1164__resolved_RESOLV_ptr"); + + procedure Free is new Ada.Unchecked_Deallocation + (Name => Resolved_Signal_Acc, Object => Resolved_Signal_Type); + + procedure Order_All_Signals + is + Sig : Ghdl_Signal_Ptr; + Resolv : Resolved_Signal_Acc; + begin + -- Do checks and optimization. + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + -- LRM 5.3 + -- If, by the above rules, no disconnection specification applies to + -- the drivers of a guarded, scalar signal S whose type mark is T + -- (including a scalar subelement of a composite signal), then the + -- following default disconnection specification is implicitly + -- assumed: + -- disconnect S : T after 0 ns; + if Sig.S.Mode_Sig in Mode_Signal_User then + Resolv := Sig.S.Resolv; + if Resolv /= null and then Resolv.Disconnect_Time = Bad_Time then + Resolv.Disconnect_Time := 0; + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last > I + then + -- Check every scalar subelement of a resolved signal + -- has a driver in the same process. + Check_Resolved_Driver (Resolv); + end if; + + if Resolv /= null + and then Resolv.Sig_Range.First = I + and then Resolv.Sig_Range.Last = I + and then + (Resolv.Resolv_Proc + = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr)) + and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1 + then + -- Optimization: remove resolver if there is at most one + -- source. + Free (Sig.S.Resolv); + end if; + end if; + end loop; + + -- Really order them. + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Driving); + end loop; + for I in Sig_Table.First .. Sig_Table.Last loop + Order_Signal (Sig_Table.Table (I), Propag_Done); + end loop; + + Create_Nets; + end Order_All_Signals; + + -- Add SIG in active_chain. + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr); + pragma Inline (Add_Active_Chain); + + procedure Add_Active_Chain (Sig : Ghdl_Signal_Ptr) + is + begin + if Sig.Link = null then + Sig.Link := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Sig; + end if; + end Add_Active_Chain; + + Clear_List : Ghdl_Signal_Ptr := null; + + -- Mark SIG as active and put it on Clear_List (if not already). + procedure Mark_Active (Sig : Ghdl_Signal_Ptr); + pragma Inline (Mark_Active); + + procedure Mark_Active (Sig : Ghdl_Signal_Ptr) + is + begin + if not Sig.Active then + Sig.Active := True; + Sig.Last_Active := Current_Time; + Sig.Alink := Clear_List; + Clear_List := Sig; + end if; + end Mark_Active; + + procedure Set_Guard_Activity (Sig : Ghdl_Signal_Ptr) is + begin + for I in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (I - 1).Active then + Mark_Active (Sig); + return; + end if; + end loop; + end Set_Guard_Activity; + + procedure Set_Stable_Quiet_Activity + (Mode : Propagation_Kind_Type; Sig : Ghdl_Signal_Ptr) is + begin + case Mode is + when Imp_Stable => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Event then + Mark_Active (Sig); + return; + end if; + end loop; + when Imp_Quiet + | Imp_Transaction => + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + return; + end if; + end loop; + when others => + Internal_Error ("set_stable_quiet_activity"); + end case; + end Set_Stable_Quiet_Activity; + + function Get_Resolved_Activity (Sig : Ghdl_Signal_Ptr) return Boolean + is + Trans : Transaction_Acc; + Res : Boolean := False; + begin + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + -- In fact we knew the signal was active! + Res := True; + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + Res := True; + end if; + end if; + end loop; + if Res then + return True; + end if; + for J in 1 .. Sig.Nbr_Ports loop + if Sig.Ports (J - 1).Active then + return True; + end if; + end loop; + return False; + end Get_Resolved_Activity; + + procedure Set_Conversion_Activity (Conv : Sig_Conversion_Acc) + is + Active : Boolean := False; + begin + for I in Conv.Src.First .. Conv.Src.Last loop + Active := Active or Sig_Table.Table (I).Active; + end loop; + if Active then + Call_Conversion_Function (Conv); + end if; + for I in Conv.Dest.First .. Conv.Dest.Last loop + Sig_Table.Table (I).Active := Active; + end loop; + end Set_Conversion_Activity; + + procedure Delayed_Implicit_Process (Sig : Ghdl_Signal_Ptr) + is + Pfx : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + Last : Transaction_Acc; + Prev : Transaction_Acc; + begin + Pfx := Sig.Ports (0); + if Pfx.Event then + -- LRM 14.1 + -- P: process (S) + -- begin + -- R <= transport S after T; + -- end process; + Trans := new Transaction'(Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Pfx.Value); + -- Find the last transaction. + Last := Sig.S.Attr_Trans; + Prev := Last; + while Last.Next /= null loop + Prev := Last; + Last := Last.Next; + end loop; + -- Maybe, remove it. + if Last.Time > Trans.Time then + Internal_Error ("delayed time"); + elsif Last.Time = Trans.Time then + if Prev /= Last then + Free (Last); + else + -- No transaction. + if Last.Time /= 0 then + -- This can happen only at time = 0. + Internal_Error ("delayed"); + end if; + end if; + else + Prev := Last; + end if; + -- Append the transaction. + Prev.Next := Trans; + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + end if; + end Delayed_Implicit_Process; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union) + is + El : Action_List_Acc; + begin + if not Value_Equal (Sig.Value, Val, Sig.Mode) then + Sig.Last_Value := Sig.Value; + Sig.Value := Val; + Sig.Event := True; + Sig.Last_Event := Current_Time; + Sig.Flags.Cyc_Event := True; + + El := Sig.Event_List; + while El /= null loop + Resume_Process (El.Proc); + El := El.Next; + end loop; + end if; + end Set_Effective_Value; + + procedure Run_Propagation (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + First_Trans : Transaction_Acc; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + Sig := Propagation.Table (I).Sig; + First_Trans := Sig.S.Drivers (0).First_Trans; + Trans := First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + -- Note: already or will be marked as active in + -- update_signals. + Mark_Active (Sig); + Direct_Assign (First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + Sig.Driving_Value := First_Trans.Val; + elsif Trans.Time = Current_Time then + Mark_Active (Sig); + Free (First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("run_propagation: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + end if; + end if; + when Drv_One_Resolved + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Get_Resolved_Activity (Sig) then + Mark_Active (Sig); + Compute_Resolved_Signal (Propagation.Table (I).Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + Sig := Propagation.Table (I).Sig; + if Sig.Ports (0).Active then + Mark_Active (Sig); + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + end if; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + -- Note: the signal may have drivers (inout ports). + if Sig.S.Effective.Active and not Sig.Active then + Mark_Active (Sig); + end if; + when Drv_Multiple + | Eff_Multiple => + declare + Active : Boolean := False; + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Active := Active or Get_Resolved_Activity (Sig); + end loop; + if Active then + -- Mark the first signal as active (since only this one + -- will be checked to set effective value). + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Mark_Active (Sig_Table.Table (I)); + end loop; + Compute_Resolved_Signal (Resolv); + end if; + end; + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward_Build => + null; + when Imp_Forward => + Sig := Propagation.Table (I).Sig; + if Sig.Link = null then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + end if; + when In_Conversion => + null; + when Out_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("update signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + if Sig_Table.Table (Resolv.Sig_Range.First).Active then + -- If one signal is active, all are active. + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last + loop + Sig := Sig_Table.Table (I); + Set_Effective_Value (Sig, Sig.Driving_Value); + end loop; + end if; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.S.Effective.Value); + end if; + when Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Set_Guard_Activity (Sig); + if Sig.Active then + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + when Imp_Stable + | Imp_Quiet => + Sig := Propagation.Table (I).Sig; + Set_Stable_Quiet_Activity (Propagation.Table (I).Kind, Sig); + if Sig.Active then + Sig.Driving_Value := + Value_Union'(Mode => Mode_B1, B1 => False); + -- Set driver. + Trans := new Transaction' + (Kind => Trans_Value, + Line => 0, + Time => Current_Time + Sig.S.Time, + Next => null, + Val => Value_Union'(Mode => Mode_B1, B1 => True)); + if Sig.S.Attr_Trans.Next /= null then + Free (Sig.S.Attr_Trans.Next); + end if; + Sig.S.Attr_Trans.Next := Trans; + Set_Effective_Value (Sig, Sig.Driving_Value); + if Sig.S.Time = 0 then + Add_Active_Chain (Sig); + end if; + else + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Mark_Active (Sig); + Free (Sig.S.Attr_Trans); + Sig.S.Attr_Trans := Trans; + Sig.Driving_Value := Trans.Val; + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + end if; + when Imp_Transaction => + -- LRM 12.6.3 Updating Implicit Signals + -- Finally, for any implicit signal S'Transaction, the current + -- value of the signal is modified if and only if S is active. + -- If signal S is active, then S'Transaction is updated by + -- assigning the value of the expression (not S'Transaction) + -- to the variable representing the current value of + -- S'Transaction. + Sig := Propagation.Table (I).Sig; + for I in 0 .. Sig.Nbr_Ports - 1 loop + if Sig.Ports (I).Active then + Mark_Active (Sig); + Set_Effective_Value + (Sig, Value_Union'(Mode => Mode_B1, + B1 => not Sig.Value.B1)); + exit; + end if; + end loop; + when Imp_Delayed => + Sig := Propagation.Table (I).Sig; + if Sig.Active then + Set_Effective_Value (Sig, Sig.Driving_Value); + end if; + Delayed_Implicit_Process (Sig); + when In_Conversion => + Set_Conversion_Activity (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("run_propagation(2)"); + end case; + I := I + 1; + end loop; + end Run_Propagation; + + procedure Reset_Active_Flag + is + Sig : Ghdl_Signal_Ptr; + begin + -- 1) Reset active flag. + Sig := Clear_List; + Clear_List := null; + while Sig /= null loop + if Options.Flag_Stats then + if Sig.Active then + Nbr_Active := Nbr_Active + 1; + end if; + if Sig.Event then + Nbr_Events := Nbr_Events + 1; + end if; + end if; + Sig.Active := False; + Sig.Event := False; + + Sig := Sig.Alink; + end loop; + +-- for I in Sig_Table.First .. Sig_Table.Last loop +-- Sig := Sig_Table.Table (I); +-- if Sig.Active or Sig.Event then +-- Internal_Error ("reset_active_flag"); +-- end if; +-- end loop; + end Reset_Active_Flag; + + procedure Update_Signals + is + Sig : Ghdl_Signal_Ptr; + Next_Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + -- LRM93 12.6.2 + -- 1) Reset active flag. + Reset_Active_Flag; + + -- For each active signals + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.S.Mode_Sig /= Mode_End loop + Next_Sig := Sig.Link; + Sig.Link := null; + + case Sig.Net is + when Net_One_Driver => + -- This signal is active. + Mark_Active (Sig); + + Trans := Sig.S.Drivers (0).First_Trans.Next; + Free (Sig.S.Drivers (0).First_Trans); + Sig.S.Drivers (0).First_Trans := Trans; + case Trans.Kind is + when Trans_Value => + Sig.Driving_Value := Trans.Val; + when Trans_Direct => + Internal_Error ("update_signals: trans_direct"); + when Trans_Null => + Error ("null transaction"); + when Trans_Error => + Error_Trans_Error (Trans); + end case; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Direct => + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + Trans := Sig.S.Drivers (0).Last_Trans; + Direct_Assign (Sig.Driving_Value, Trans.Val_Ptr, Sig.Mode); + Sig.S.Drivers (0).First_Trans.Val := Sig.Driving_Value; + Set_Effective_Value (Sig, Sig.Driving_Value); + + when Net_One_Resolved => + -- This signal is active. + Mark_Active (Sig); + Sig.Is_Direct_Active := False; + + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).First_Trans.Next; + if Trans /= null then + if Trans.Kind = Trans_Direct then + Direct_Assign (Sig.S.Drivers (J - 1).First_Trans.Val, + Trans.Val_Ptr, Sig.Mode); + elsif Trans.Time = Current_Time then + Free (Sig.S.Drivers (J - 1).First_Trans); + Sig.S.Drivers (J - 1).First_Trans := Trans; + end if; + end if; + end loop; + Compute_Resolved_Signal (Sig.S.Resolv); + Set_Effective_Value (Sig, Sig.Driving_Value); + + when No_Signal_Net => + Internal_Error ("update_signals: no_signal_net"); + + when others => + Sig.Is_Direct_Active := False; + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end case; + + Sig := Next_Sig; + end loop; + + -- Implicit signals (forwarded). + loop + Sig := Ghdl_Implicit_Signal_Active_Chain; + exit when Sig.Link = null; + Ghdl_Implicit_Signal_Active_Chain := Sig.Link; + Sig.Link := null; + + if not Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := True; + Run_Propagation (Sig.Net + 1); + + -- Put it on the list, so that updated flag will be cleared. + Add_Active_Chain (Sig); + end if; + end loop; + + -- Un-mark updated. + Sig := Ghdl_Signal_Active_Chain; + Ghdl_Signal_Active_Chain := Signal_End; + while Sig.Link /= null loop + Propagation.Table (Sig.Net).Updated := False; + Next_Sig := Sig.Link; + Sig.Link := null; + + -- Maybe put SIG in the active list, if it will be active during + -- the next cycle. + -- This can happen only for 'quiet, 'stable or 'delayed. + case Sig.S.Mode_Sig is + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + declare + Trans : Transaction_Acc; + begin + Trans := Sig.S.Attr_Trans.Next; + if Trans /= null and then Trans.Time = Current_Time then + Sig.Link := Ghdl_Implicit_Signal_Active_Chain; + Ghdl_Implicit_Signal_Active_Chain := Sig; + end if; + end; + when others => + null; + end case; + + Sig := Next_Sig; + end loop; + end Update_Signals; + + procedure Run_Propagation_Init (Start : Signal_Net_Type) + is + I : Signal_Net_Type; + Sig : Ghdl_Signal_Ptr; + begin + I := Start; + loop + -- First: the driving value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Eff_One_Driver => + -- Nothing to do: drivers were already created. + null; + when Drv_One_Resolved + | Eff_One_Resolved => + -- Execute the resolution function. + Sig := Propagation.Table (I).Sig; + if Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + end if; + when Drv_One_Port + | Eff_One_Port => + -- Copy value. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when Eff_Actual => + null; + when Drv_Multiple + | Eff_Multiple => + Compute_Resolved_Signal (Propagation.Table (I).Resolv); + when Imp_Guard + | Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + null; + when Imp_Delayed => + -- LRM 14.1 + -- Assuming that the initial value of R is the same as the + -- initial value of S, [...] + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value := Sig.Ports (0).Driving_Value; + when In_Conversion => + null; + when Out_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Prop_End => + return; + when Drv_Error => + Internal_Error ("init_signals"); + end case; + + -- Second: the effective value. + case Propagation.Table (I).Kind is + when Drv_One_Driver + | Drv_One_Port + | Drv_One_Resolved + | Drv_Multiple => + null; + when Eff_One_Driver + | Eff_One_Port + | Eff_One_Resolved + | Imp_Delayed => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.Driving_Value; + when Eff_Multiple => + declare + Resolv : Resolved_Signal_Acc; + begin + Resolv := Propagation.Table (I).Resolv; + for I in Resolv.Sig_Range.First .. Resolv.Sig_Range.Last loop + Sig := Sig_Table.Table (I); + Sig.Value := Sig.Driving_Value; + end loop; + end; + when Eff_Actual => + Sig := Propagation.Table (I).Sig; + Sig.Value := Sig.S.Effective.Value; + when Imp_Guard => + -- Guard signal is active iff one of its dependence is active. + Sig := Propagation.Table (I).Sig; + Sig.Driving_Value.B1 := + Sig.S.Guard_Func.all (Sig.S.Guard_Instance); + Sig.Value := Sig.Driving_Value; + when Imp_Stable + | Imp_Quiet + | Imp_Transaction + | Imp_Forward + | Imp_Forward_Build => + -- Already initialized during creation. + null; + when In_Conversion => + Call_Conversion_Function (Propagation.Table (I).Conv); + when Out_Conversion => + null; + when Prop_End => + null; + when Drv_Error => + Internal_Error ("init_signals(2)"); + end case; + + I := I + 1; + end loop; + end Run_Propagation_Init; + + procedure Init_Signals + is + Sig : Ghdl_Signal_Ptr; + begin + for I in Sig_Table.First .. Sig_Table.Last loop + Sig := Sig_Table.Table (I); + + case Sig.Net is + when Net_One_Driver + | Net_One_Direct => + -- Nothing to do: drivers were already created. + null; + + when Net_One_Resolved => + Sig.Has_Active := True; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 0 then + Compute_Resolved_Signal (Sig.S.Resolv); + Sig.Value := Sig.Driving_Value; + end if; + + when No_Signal_Net => + null; + + when others => + if Propagation.Table (Sig.Net).Updated then + Propagation.Table (Sig.Net).Updated := False; + Run_Propagation_Init (Sig.Net + 1); + end if; + end case; + end loop; + + end Init_Signals; + + procedure Init is + begin + Signal_End := new Ghdl_Signal'(Value => (Mode => Mode_B1, + B1 => False), + Driving_Value => (Mode => Mode_B1, + B1 => False), + Last_Value => (Mode => Mode_B1, + B1 => False), + Last_Event => 0, + Last_Active => 0, + Event => False, + Active => False, + Has_Active => False, + Is_Direct_Active => False, + Sig_Kind => Kind_Signal_No, + Mode => Mode_B1, + + Flags => (Propag => Propag_None, + Is_Dumped => False, + Cyc_Event => False, + Seen => False), + + Net => No_Signal_Net, + Link => null, + Alink => null, + Flink => null, + + Event_List => null, + Rti => null, + + Nbr_Ports => 0, + Ports => null, + + S => (Mode_Sig => Mode_End)); + + Ghdl_Signal_Active_Chain := Signal_End; + Ghdl_Implicit_Signal_Active_Chain := Signal_End; + Future_List := Signal_End; + + Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr; + Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr; + end Init; + +end Grt.Signals; diff --git a/src/translate/grt/grt-signals.ads b/src/translate/grt/grt-signals.ads new file mode 100644 index 0000000..d792f16 --- /dev/null +++ b/src/translate/grt/grt-signals.ads @@ -0,0 +1,919 @@ +-- GHDL Run Time (GRT) - signals management. +-- 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; +with Ada.Unchecked_Conversion; +with Grt.Table; +with Grt.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; +limited with Grt.Processes; +pragma Elaborate_All (Grt.Table); + +package Grt.Signals is + pragma Suppress (All_Checks); + + -- Kind of transaction. + type Transaction_Kind is + ( + -- Normal transaction, with a value. + Trans_Value, + -- Normal transaction, with a pointer to a value (direct assignment). + Trans_Direct, + -- Null transaction. + Trans_Null, + -- Like a normal transaction, but without a value due to check error. + Trans_Error + ); + + type Transaction; + type Transaction_Acc is access Transaction; + type Transaction (Kind : Transaction_Kind) is record + -- Line for error. Put here to compact the record. + Line : Ghdl_I32; + + Next : Transaction_Acc; + Time : Std_Time; + case Kind is + when Trans_Value => + Val : Value_Union; + when Trans_Direct => + Val_Ptr : Ghdl_Value_Ptr; + when Trans_Null => + null; + when Trans_Error => + -- Filename for error. + File : Ghdl_C_String; + end case; + end record; + + type Process_Acc is access Grt.Processes.Process_Type; + + -- A driver is bound to a process (PROC) and contains a list of + -- transactions. + type Driver_Type is record + First_Trans : Transaction_Acc; + Last_Trans : Transaction_Acc; + Proc : Process_Acc; + end record; + + type Driver_Acc is access all Driver_Type; + type Driver_Fat_Array is array (Ghdl_Index_Type) of aliased Driver_Type; + type Driver_Arr_Ptr is access Driver_Fat_Array; + + -- Function access type used to evaluate the guard expression. + type Guard_Func_Acc is access function (This : System.Address) + return Ghdl_B1; + pragma Convention (C, Guard_Func_Acc); + + -- Simply linked list of processes to be resumed in case of events. + + type Ghdl_Signal; + type Ghdl_Signal_Ptr is access Ghdl_Signal; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Ghdl_Signal_Ptr); + + type Signal_Fat_Array is array (Ghdl_Index_Type) of Ghdl_Signal_Ptr; + type Signal_Arr_Ptr is access Signal_Fat_Array; + + function To_Signal_Arr_Ptr is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Signal_Arr_Ptr); + + -- List of processes to wake-up in case of event on the signal. + type Action_List; + type Action_List_Acc is access Action_List; + + type Action_List (Dynamic : Boolean) is record + -- Next action for the current signal. + Next : Action_List_Acc; + + -- Process to wake-up. + Proc : Process_Acc; + + case Dynamic is + when True => + -- For a non-sensitized process. + -- Previous action (to speed-up remove from the chain). + Prev : Action_List_Acc; + + Sig : Ghdl_Signal_Ptr; + + -- Chain of signals for the process. + Chain : Action_List_Acc; + when False => + null; + end case; + end record; + + -- Resolution function. + -- There is a wrapper around resolution functions to simplify the call + -- from GRT. + -- INSTANCE is the opaque parameter given when the resolver is + -- registers (RESOLV_INST). + -- VAL is the signal (which may be composite). + -- BOOL_VEC is an array of NBR_DRV booleans (bytes) and indicates + -- non-null drivers. There are VEC_LEN non-null drivers. So the number + -- of values is VEC_LEN + NBR_PORTS. This number of values is the length + -- of the array for the resolution function. + type Resolver_Acc is access procedure + (Instance : System.Address; + Val : System.Address; + Bool_Vec : System.Address; + Vec_Len : Ghdl_Index_Type; + Nbr_Drv : Ghdl_Index_Type; + Nbr_Ports : Ghdl_Index_Type); + + -- On some platforms, GNAT use a descriptor (instead of a trampoline) for + -- nested subprograms. This descriptor contains the address of the + -- subprogram and the address of the chain. An unaligned pointer to this + -- descriptor (address + 1) is then used for 'Access, and every indirect + -- call check for unaligned address. + -- + -- Disable this feature (as a resolver is never a nested subprogram), so + -- code generated by ghdl is compatible with ghdl runtimes built with + -- gnat. + pragma Convention (C, Resolver_Acc); + + -- How to compute resolved signal. + type Resolved_Signal_Type is record + Resolv_Proc : Resolver_Acc; + Resolv_Inst : System.Address; + Resolv_Ptr : System.Address; + Sig_Range : Sig_Table_Range; + Disconnect_Time : Std_Time; + end record; + + type Resolved_Signal_Acc is access Resolved_Signal_Type; + + type Conversion_Func_Acc is access procedure (Instance : System.Address); + pragma Convention (C, Conversion_Func_Acc); + + function To_Conversion_Func_Acc is new Ada.Unchecked_Conversion + (Source => System.Address, Target => Conversion_Func_Acc); + + -- Signal conversion data. + type Sig_Conversion_Type is record + -- Function which performs the conversion. + Func : System.Address; + Instance : System.Address; + + Src : Sig_Table_Range; + Dest : Sig_Table_Range; + end record; + type Sig_Conversion_Acc is access Sig_Conversion_Type; + + type Forward_Build_Type is record + Src : Ghdl_Signal_Ptr; + Targ : Ghdl_Signal_Ptr; + end record; + type Forward_Build_Acc is access Forward_Build_Type; + + -- Used to order the signals for the propagation of signals values. + type Propag_Order_Flag is + ( + -- The signal was not yet ordered. + Propag_None, + -- The signal is being ordered for driving value. + -- This stage is used to catch loop (which can not occur). + Propag_Being_Driving, + -- The signal has been ordered for driving value. + Propag_Driving, + -- The signal is being ordered for effective value. + Propag_Being_Effective, + -- The signal has completly been ordered. + Propag_Done); + + -- Each signal belongs to a signal_net. + -- Signals on the same net must be updated in order. + -- Signals on different nets have no direct relation-ship, and thus may + -- be updated without order. + -- Net NO_SIGNAL_NET is special: it groups all lonely signals. + type Signal_Net_Type is new Integer; + No_Signal_Net : constant Signal_Net_Type := 0; + Net_One_Driver : constant Signal_Net_Type := -1; + Net_One_Direct : constant Signal_Net_Type := -2; + Net_One_Resolved : constant Signal_Net_Type := -3; + + -- Flush the list of active signals. + procedure Flush_Active_List; + + type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal) + is record + case Mode_Sig is + when Mode_Signal_User => + Nbr_Drivers : Ghdl_Index_Type; + Drivers : Driver_Arr_Ptr; + + -- Signal which defines the effective value of this signal, + -- if any. + Effective : Ghdl_Signal_Ptr; + + -- Null if not resolved. + Resolv : Resolved_Signal_Acc; + + when Mode_Conv_In + | Mode_Conv_Out => + -- Conversion paramaters for conv_in, conv_out. + Conv : Sig_Conversion_Acc; + + when Mode_Stable + | Mode_Quiet + | Mode_Delayed => + -- Time parameter for 'stable, 'quiet or 'delayed + Time : Std_Time; + Attr_Trans : Transaction_Acc; + + when Mode_Guard => + -- Guard function and instance used to compute the + -- guard expression. + Guard_Func : Guard_Func_Acc; + Guard_Instance : System.Address; + + when Mode_Transaction + | Mode_End => + null; + end case; + end record; + pragma Suppress (Discriminant_Check, On => Ghdl_Signal_Data); + + type Ghdl_Signal_Flags is record + -- Status of the ordering. + Propag : Propag_Order_Flag; + + -- If set, the signal is dumped in a GHW file. + Is_Dumped : Boolean; + + -- Set when an event occured. + -- Only reset by GHW file dumper. + Cyc_Event : Boolean; + + -- Set if the signal has already been visited. When outside of the + -- algorithm that use it, it must be cleared. + Seen : Boolean; + end record; + pragma Pack (Ghdl_Signal_Flags); + + type Ghdl_Signal is record + -- Fields known by the compilers. + Value : Value_Union; + Driving_Value : Value_Union; + Last_Value : Value_Union; + Last_Event : Std_Time; + Last_Active : Std_Time; + + Event : Boolean; + Active : Boolean; + -- If set, the activity of the signal is required by the user. + Has_Active : Boolean; + + -- Internal fields. + -- NOTE: keep above fields (components) in sync with translation. + + -- If set, the signal has an active direct driver. + Is_Direct_Active : Boolean; + + -- Kind of the signal (none, bus or register). + Sig_Kind : Kind_Signal_Type; + + -- Values mode of this signal. + Mode : Mode_Type; + + -- Misc flags. + Flags : Ghdl_Signal_Flags; + + -- Net of the signal. + Net : Signal_Net_Type; + + -- Chain of signals that will be active in the next delta-cycle. + -- (Also used to build nets). + Link : Ghdl_Signal_Ptr; + + -- Chain of signals whose active flag was set. Used to clear the active + -- flag at the end of the delta cycle. + Alink : Ghdl_Signal_Ptr; + + -- Chain of signals that have a projected waveform in the real future. + Flink : Ghdl_Signal_Ptr; + + -- List of processes to resume when there is an event on + -- this signal. + Event_List : Action_List_Acc; + + -- Path of the signal (with its name) in the design hierarchy. + -- Used to get the type of the signal. + Rti : Ghdl_Rtin_Object_Acc; + + -- For user signals: the sources of a signals are drivers + -- and connected ports. + -- For implicit signals: PORTS is used as dependence list. + Nbr_Ports : Ghdl_Index_Type; + Ports : Signal_Arr_Ptr; + + -- Mode of the signal (in, out ...) + --Mode_Signal : Mode_Signal_Type; + S : Ghdl_Signal_Data; + end record; + + -- Each simple signal declared can be accessed by SIG_TABLE. + package Sig_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Sig_Table_Index, + Table_Low_Bound => 0, + Table_Initial => 128); + + -- Return the next time at which a driver becomes active. + function Find_Next_Time return Std_Time; + + -- Elementary propagation computation. + -- See LRM 12.6.2 and 12.6.3 + type Propagation_Kind_Type is + ( + -- How to compute driving value: + -- Default value. + Drv_Error, + + -- One source, a driver and not resolved: + -- the driving value is the driver. + Drv_One_Driver, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Driver, + + -- One source, a port and not resolved: + -- the driving value is the driving value of the port. + -- Dependence. + Drv_One_Port, + + -- Same as previous, and the effective value is the driving value. + Eff_One_Port, + + -- Several sources or resolved: + -- signal is not composite. + Drv_One_Resolved, + Eff_One_Resolved, + + -- Use the resolution function, signal is composite. + Drv_Multiple, + + -- Same as previous, but the effective value is the previous value. + Eff_Multiple, + + -- The effective value is the actual associated. + Eff_Actual, + + -- Sig must be updated but does not belong to the same net. + Imp_Forward, + Imp_Forward_Build, + + -- Implicit guard signal. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Guard, + + -- Implicit stable. + -- Its value must be evaluated after the effective value of its + -- dependences. + Imp_Stable, + + -- Implicit quiet. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Quiet, + + -- Implicit transaction. + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Transaction, + + -- Implicit delayed + -- Its value must be evaluated after the driving value of its + -- dependences. + Imp_Delayed, + + -- in_conversion. + -- Pseudo-signal which is set by conversion function. + In_Conversion, + Out_Conversion, + + -- End of propagation. + Prop_End + ); + + type Propagation_Type (Kind : Propagation_Kind_Type := Drv_Error) is record + case Kind is + when Drv_Error => + null; + when Drv_One_Driver + | Eff_One_Driver + | Drv_One_Port + | Eff_One_Port + | Imp_Forward + | Imp_Guard + | Imp_Quiet + | Imp_Transaction + | Imp_Stable + | Imp_Delayed + | Eff_Actual + | Eff_One_Resolved + | Drv_One_Resolved => + Sig : Ghdl_Signal_Ptr; + when Drv_Multiple + | Eff_Multiple => + Resolv : Resolved_Signal_Acc; + when In_Conversion + | Out_Conversion => + Conv : Sig_Conversion_Acc; + when Imp_Forward_Build => + Forward : Forward_Build_Acc; + when Prop_End => + Updated : Boolean; + end case; + end record; + + package Propagation is new Grt.Table + (Table_Component_Type => Propagation_Type, + Table_Index_Type => Signal_Net_Type, + Table_Low_Bound => 1, + Table_Initial => 128); + + -- Get the signal index of PTR. + function Signal_Ptr_To_Index (Ptr : Ghdl_Signal_Ptr) return Sig_Table_Index; + + -- Compute propagation order of signals. + procedure Order_All_Signals; + + -- Initialize the package (mainly the lists). + procedure Init; + + -- Initialize all signals. + procedure Init_Signals; + + -- Update signals. + procedure Update_Signals; + + -- Set the effective value of signal SIG to VAL. + -- If the value is different from the previous one, resume processes. + procedure Set_Effective_Value (Sig : Ghdl_Signal_Ptr; Val : Value_Union); + + -- Add PROC in the list of processes to be resumed in case of event on + -- SIG. + procedure Resume_Process_If_Event + (Sig : Ghdl_Signal_Ptr; Proc : Process_Acc); + + -- Creating a signal: + -- 1a) call Ghdl_Signal_Name_Rti (CTXT and ADDR are unused) to register + -- the RTI for the whole signal (in particular the mode and the + -- has_active flag) + -- or + -- 1b) call Ghdl_Signal_Set_Mode to register the mode and the has_active + -- flag. In that case, the signal has no name. + -- + -- 2) call Ghdl_Create_Signal_XXX for each non-composite element + + procedure Ghdl_Signal_Name_Rti (Sig : Ghdl_Rti_Access; + Ctxt : Ghdl_Rti_Access; + Addr : System.Address); + + procedure Ghdl_Signal_Set_Mode (Mode : Mode_Signal_Type; + Kind : Kind_Signal_Type; + Has_Active : Boolean); + + -- FIXME: document. + -- Merge RTI with SIG: adjust the has_active flag of SIG according to RTI. + procedure Ghdl_Signal_Merge_Rti (Sig : Ghdl_Signal_Ptr; + Rti : Ghdl_Rti_Access); + + -- Assigning a waveform to a signal: + -- + -- For simple waveform (sig <= val), the short form can be used: + -- Ghdl_Signal_Simple_Assign_XX (Sig, Val); + -- For all other forms + -- SIG <= reject R inertial V1 after T1, V2 after T2, ...: + -- Ghdl_Signal_Start_Assign_XX (SIG, R, V1, T1); + -- Ghdl_Signal_Next_Assign_XX (SIG, V2, T2); + -- ... + -- If the delay mechanism is transport, they R = 0, + -- if there is no rejection time, the mechanism is internal and R = T1. + + -- Performs some internal checks on signals (transaction order). + -- Internal_error is called in case of error. + procedure Ghdl_Signal_Internal_Checks; + + procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_Error (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + procedure Ghdl_Signal_Next_Assign_Error (Sign : Ghdl_Signal_Ptr; + After : Std_Time; + File : Ghdl_C_String; + Line : Ghdl_I32); + + procedure Ghdl_Signal_Direct_Assign (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Set_Disconnect (Sign : Ghdl_Signal_Ptr; + Time : Std_Time); + + procedure Ghdl_Signal_Disconnect (Sign : Ghdl_Signal_Ptr); + + procedure Ghdl_Signal_Start_Assign_Null (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + After : Std_Time); + + function Ghdl_Signal_Driving (Sig : Ghdl_Signal_Ptr) return Ghdl_B1; + + function Ghdl_Create_Signal_B1 (Init_Val : Ghdl_B1; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_B1 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_B1); + procedure Ghdl_Signal_Associate_B1 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_B1); + procedure Ghdl_Signal_Simple_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1); + procedure Ghdl_Signal_Start_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_B1; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_B1 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_B1; + After : Std_Time); + function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) + return Ghdl_B1; + + function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E8 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E8); + procedure Ghdl_Signal_Associate_E8 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E8); + procedure Ghdl_Signal_Simple_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8); + procedure Ghdl_Signal_Start_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E8; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E8 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E8; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E8; + + function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_E32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_E32); + procedure Ghdl_Signal_Associate_E32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_E32); + procedure Ghdl_Signal_Simple_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32); + procedure Ghdl_Signal_Start_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_E32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_E32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_E32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_E32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_E32; + + function Ghdl_Create_Signal_I32 (Init_Val : Ghdl_I32; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I32 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I32); + procedure Ghdl_Signal_Associate_I32 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I32); + procedure Ghdl_Signal_Simple_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32); + procedure Ghdl_Signal_Start_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I32; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I32 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I32; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I32 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I32; + + function Ghdl_Create_Signal_I64 (Init_Val : Ghdl_I64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_I64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_I64); + procedure Ghdl_Signal_Associate_I64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_I64); + procedure Ghdl_Signal_Simple_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64); + procedure Ghdl_Signal_Start_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_I64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_I64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_I64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_I64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_I64; + + function Ghdl_Create_Signal_F64 (Init_Val : Ghdl_F64; + Resolv_Func : Resolver_Acc; + Resolv_Inst : System.Address) + return Ghdl_Signal_Ptr; + procedure Ghdl_Signal_Init_F64 (Sig : Ghdl_Signal_Ptr; Init_Val : Ghdl_F64); + procedure Ghdl_Signal_Associate_F64 (Sig : Ghdl_Signal_Ptr; Val : Ghdl_F64); + procedure Ghdl_Signal_Simple_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64); + procedure Ghdl_Signal_Start_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Rej : Std_Time; + Val : Ghdl_F64; + After : Std_Time); + procedure Ghdl_Signal_Next_Assign_F64 (Sign : Ghdl_Signal_Ptr; + Val : Ghdl_F64; + After : Std_Time); + function Ghdl_Signal_Driving_Value_F64 (Sig : Ghdl_Signal_Ptr) + return Ghdl_F64; + + -- Add a driver to SIGN for the current process. + procedure Ghdl_Process_Add_Driver (Sign : Ghdl_Signal_Ptr); + + -- Add a direct driver for the current process. This is an optimization + -- that could be used when a driver has no projected waveforms. + -- + -- Assignment using direct driver: + -- * the driver value is set + -- * put the signal on the ghdl_signal_active_chain, if the signal will + -- be active and if not already on the chain. + procedure Ghdl_Signal_Add_Direct_Driver (Sign : Ghdl_Signal_Ptr; + Drv : Ghdl_Value_Ptr); + + -- Used for connexions: + -- SRC is a source for TARG. + procedure Ghdl_Signal_Add_Source (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- The effective value of TARG is the effective value of SRC. + procedure Ghdl_Signal_Effective_Value (Targ : Ghdl_Signal_Ptr; + Src : Ghdl_Signal_Ptr); + + -- Conversions. In order to do conversion from A to B, an intermediate + -- signal T must be created. The flow is A -> T -> B. + -- The link from A -> T is a conversion, added by one of the two + -- following procedures. The type of A and T is different. + -- The link from T -> B is a normal connection: either an effective + -- one (for in conversion) or a source (for out conversion). + + -- Add an in conversion (from SRC to DEST using function FUNC). + -- The effective value can be read and writen directly. + procedure Ghdl_Signal_In_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Add an out conversion. + -- The driving value can be read and writen directly. + procedure Ghdl_Signal_Out_Conversion (Func : System.Address; + Instance : System.Address; + Src : Ghdl_Signal_Ptr; + Src_Len : Ghdl_Index_Type; + Dst : Ghdl_Signal_Ptr; + Dst_Len : Ghdl_Index_Type); + + -- Mark the next (and not yet created) NBR_SIG signals as resolved. + procedure Ghdl_Signal_Create_Resolution (Proc : Resolver_Acc; + Instance : System.Address; + Sig : System.Address; + Nbr_Sig : Ghdl_Index_Type); + + -- Create a new 'stable (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Stable_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'quiet (VAL) signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Quiet_Signal (Val : Std_Time) return Ghdl_Signal_Ptr; + -- Create a new 'transaction signal. The prefixes are set by + -- ghdl_signal_attribute_register_prefix. + function Ghdl_Create_Transaction_Signal return Ghdl_Signal_Ptr; + + -- Create a new SIG'delayed (VAL) signal. + function Ghdl_Create_Delayed_Signal (Sig : Ghdl_Signal_Ptr; Val : Std_Time) + return Ghdl_Signal_Ptr; + + -- Add SIG in the set of prefix for the last created signal. + procedure Ghdl_Signal_Attribute_Register_Prefix (Sig : Ghdl_Signal_Ptr); + + -- Create a new implicitly defined GUARD signal. + function Ghdl_Signal_Create_Guard (This : System.Address; + Proc : Guard_Func_Acc) + return Ghdl_Signal_Ptr; + + -- Add SIG to the list of referenced signals that appear in the guard + -- expression. + procedure Ghdl_Signal_Guard_Dependence (Sig : Ghdl_Signal_Ptr); + + -- Return number of ports/drivers. + function Ghdl_Signal_Get_Nbr_Ports (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + function Ghdl_Signal_Get_Nbr_Drivers (Sig : Ghdl_Signal_Ptr) + return Ghdl_Index_Type; + + -- Read a source (port or driver) from a signal. This is used by + -- resolution functions. + function Ghdl_Signal_Read_Port + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + function Ghdl_Signal_Read_Driver + (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) + return Ghdl_Value_Ptr; + + Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr; + + -- Statistics. + Nbr_Active : Ghdl_I32; + Nbr_Events: Ghdl_I32; + function Get_Nbr_Future return Ghdl_I32; +private + pragma Export (C, Ghdl_Signal_Name_Rti, + "__ghdl_signal_name_rti"); + pragma Export (C, Ghdl_Signal_Merge_Rti, + "__ghdl_signal_merge_rti"); + + pragma Export (C, Ghdl_Signal_Simple_Assign_Error, + "__ghdl_signal_simple_assign_error"); + pragma Export (C, Ghdl_Signal_Start_Assign_Error, + "__ghdl_signal_start_assign_error"); + pragma Export (C, Ghdl_Signal_Next_Assign_Error, + "__ghdl_signal_next_assign_error"); + + pragma Export (C, Ghdl_Signal_Start_Assign_Null, + "__ghdl_signal_start_assign_null"); + + pragma Export (C, Ghdl_Signal_Direct_Assign, + "__ghdl_signal_direct_assign"); + + pragma Export (C, Ghdl_Signal_Set_Disconnect, + "__ghdl_signal_set_disconnect"); + pragma Export (C, Ghdl_Signal_Disconnect, + "__ghdl_signal_disconnect"); + + pragma Export (Ada, Ghdl_Signal_Driving, + "__ghdl_signal_driving"); + + pragma Export (Ada, Ghdl_Create_Signal_B1, + "__ghdl_create_signal_b1"); + pragma Export (Ada, Ghdl_Signal_Init_B1, + "__ghdl_signal_init_b1"); + pragma Export (Ada, Ghdl_Signal_Associate_B1, + "__ghdl_signal_associate_b1"); + pragma Export (Ada, Ghdl_Signal_Simple_Assign_B1, + "__ghdl_signal_simple_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Start_Assign_B1, + "__ghdl_signal_start_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Next_Assign_B1, + "__ghdl_signal_next_assign_b1"); + pragma Export (Ada, Ghdl_Signal_Driving_Value_B1, + "__ghdl_signal_driving_value_b1"); + + pragma Export (C, Ghdl_Create_Signal_E8, + "__ghdl_create_signal_e8"); + pragma Export (C, Ghdl_Signal_Init_E8, + "__ghdl_signal_init_e8"); + pragma Export (C, Ghdl_Signal_Associate_E8, + "__ghdl_signal_associate_e8"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E8, + "__ghdl_signal_simple_assign_e8"); + pragma Export (C, Ghdl_Signal_Start_Assign_E8, + "__ghdl_signal_start_assign_e8"); + pragma Export (C, Ghdl_Signal_Next_Assign_E8, + "__ghdl_signal_next_assign_e8"); + pragma Export (C, Ghdl_Signal_Driving_Value_E8, + "__ghdl_signal_driving_value_e8"); + + pragma Export (C, Ghdl_Create_Signal_E32, + "__ghdl_create_signal_e32"); + pragma Export (C, Ghdl_Signal_Init_E32, + "__ghdl_signal_init_e32"); + pragma Export (C, Ghdl_Signal_Associate_E32, + "__ghdl_signal_associate_e32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_E32, + "__ghdl_signal_simple_assign_e32"); + pragma Export (C, Ghdl_Signal_Start_Assign_E32, + "__ghdl_signal_start_assign_e32"); + pragma Export (C, Ghdl_Signal_Next_Assign_E32, + "__ghdl_signal_next_assign_e32"); + pragma Export (C, Ghdl_Signal_Driving_Value_E32, + "__ghdl_signal_driving_value_e32"); + + pragma Export (C, Ghdl_Create_Signal_I32, + "__ghdl_create_signal_i32"); + pragma Export (C, Ghdl_Signal_Init_I32, + "__ghdl_signal_init_i32"); + pragma Export (C, Ghdl_Signal_Associate_I32, + "__ghdl_signal_associate_i32"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I32, + "__ghdl_signal_simple_assign_i32"); + pragma Export (C, Ghdl_Signal_Start_Assign_I32, + "__ghdl_signal_start_assign_i32"); + pragma Export (C, Ghdl_Signal_Next_Assign_I32, + "__ghdl_signal_next_assign_i32"); + pragma Export (C, Ghdl_Signal_Driving_Value_I32, + "__ghdl_signal_driving_value_i32"); + + pragma Export (C, Ghdl_Create_Signal_I64, + "__ghdl_create_signal_i64"); + pragma Export (C, Ghdl_Signal_Init_I64, + "__ghdl_signal_init_i64"); + pragma Export (C, Ghdl_Signal_Associate_I64, + "__ghdl_signal_associate_i64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_I64, + "__ghdl_signal_simple_assign_i64"); + pragma Export (C, Ghdl_Signal_Start_Assign_I64, + "__ghdl_signal_start_assign_i64"); + pragma Export (C, Ghdl_Signal_Next_Assign_I64, + "__ghdl_signal_next_assign_i64"); + pragma Export (C, Ghdl_Signal_Driving_Value_I64, + "__ghdl_signal_driving_value_i64"); + + pragma Export (C, Ghdl_Create_Signal_F64, + "__ghdl_create_signal_f64"); + pragma Export (C, Ghdl_Signal_Init_F64, + "__ghdl_signal_init_f64"); + pragma Export (C, Ghdl_Signal_Associate_F64, + "__ghdl_signal_associate_f64"); + pragma Export (C, Ghdl_Signal_Simple_Assign_F64, + "__ghdl_signal_simple_assign_f64"); + pragma Export (C, Ghdl_Signal_Start_Assign_F64, + "__ghdl_signal_start_assign_f64"); + pragma Export (C, Ghdl_Signal_Next_Assign_F64, + "__ghdl_signal_next_assign_f64"); + pragma Export (C, Ghdl_Signal_Driving_Value_F64, + "__ghdl_signal_driving_value_f64"); + + pragma Export (C, Ghdl_Process_Add_Driver, + "__ghdl_process_add_driver"); + pragma Export (C, Ghdl_Signal_Add_Direct_Driver, + "__ghdl_signal_add_direct_driver"); + + pragma Export (C, Ghdl_Signal_Add_Source, + "__ghdl_signal_add_source"); + pragma Export (C, Ghdl_Signal_Effective_Value, + "__ghdl_signal_effective_value"); + pragma Export (C, Ghdl_Signal_In_Conversion, + "__ghdl_signal_in_conversion"); + pragma Export (C, Ghdl_Signal_Out_Conversion, + "__ghdl_signal_out_conversion"); + + pragma Export (C, Ghdl_Signal_Create_Resolution, + "__ghdl_signal_create_resolution"); + + pragma Export (C, Ghdl_Create_Stable_Signal, + "__ghdl_create_stable_signal"); + pragma Export (C, Ghdl_Create_Quiet_Signal, + "__ghdl_create_quiet_signal"); + pragma Export (C, Ghdl_Create_Transaction_Signal, + "__ghdl_create_transaction_signal"); + pragma Export (C, Ghdl_Signal_Attribute_Register_Prefix, + "__ghdl_signal_attribute_register_prefix"); + pragma Export (C, Ghdl_Create_Delayed_Signal, + "__ghdl_create_delayed_signal"); + + pragma Export (Ada, Ghdl_Signal_Create_Guard, + "__ghdl_signal_create_guard"); + pragma Export (C, Ghdl_Signal_Guard_Dependence, + "__ghdl_signal_guard_dependence"); + + pragma Export (C, Ghdl_Signal_Get_Nbr_Ports, + "__ghdl_signal_get_nbr_ports"); + pragma Export (C, Ghdl_Signal_Get_Nbr_Drivers, + "__ghdl_signal_get_nbr_drivers"); + pragma Export (C, Ghdl_Signal_Read_Port, + "__ghdl_signal_read_port"); + pragma Export (C, Ghdl_Signal_Read_Driver, + "__ghdl_signal_read_driver"); + + pragma Export (C, Ghdl_Signal_Active_Chain, + "__ghdl_signal_active_chain"); + +end Grt.Signals; diff --git a/src/translate/grt/grt-stack2.adb b/src/translate/grt/grt-stack2.adb new file mode 100644 index 0000000..82341d0 --- /dev/null +++ b/src/translate/grt/grt-stack2.adb @@ -0,0 +1,205 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- 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 Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Grt.Errors; use Grt.Errors; +with Grt.Stdio; +with Grt.Astdio; + +package body Grt.Stack2 is + -- This should be storage_elements.storage_element, but I don't want to + -- use system.storage_elements package (not pure). Unfortunatly, this is + -- currently a failure (storage_elements is automagically used). + type Memory is array (Mark_Id range <>) of Character; + + type Chunk_Type (First, Last : Mark_Id); + type Chunk_Acc is access all Chunk_Type; + type Chunk_Type (First, Last : Mark_Id) is record + Next : Chunk_Acc; + Mem : Memory (First .. Last); + end record; + + type Stack2_Type is record + First_Chunk : Chunk_Acc; + Last_Chunk : Chunk_Acc; + Top : Mark_Id; + end record; + type Stack2_Acc is access all Stack2_Type; + + function To_Acc is new Ada.Unchecked_Conversion + (Source => Stack2_Ptr, Target => Stack2_Acc); + function To_Addr is new Ada.Unchecked_Conversion + (Source => Stack2_Acc, Target => Stack2_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Chunk_Type, Name => Chunk_Acc); + + function Mark (S : Stack2_Ptr) return Mark_Id + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + return S2.Top; + end Mark; + + procedure Release (S : Stack2_Ptr; Mark : Mark_Id) + is + S2 : Stack2_Acc; + begin + S2 := To_Acc (S); + S2.Top := Mark; + end Release; + + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address + is + pragma Suppress (All_Checks); + + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + N_Chunk : Chunk_Acc; + + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Size) + Max_Align - 1) / Max_Align) * Max_Align; + + Res : System.Address; + begin + S2 := To_Acc (S); + + -- Find the chunk to which S2.TOP belong. + Chunk := S2.First_Chunk; + loop + exit when S2.Top >= Chunk.First and S2.Top <= Chunk.Last; + Chunk := Chunk.Next; + exit when Chunk = null; + end loop; + + if Chunk /= null then + -- If there is enough place in it, allocate from the chunk. + if S2.Top + Max_Size <= Chunk.Last then + Res := Chunk.Mem (S2.Top)'Address; + S2.Top := S2.Top + Max_Size; + return Res; + end if; + + -- If there is not enough place in it: + -- find a chunk which has enough room, deallocate skipped chunk. + loop + N_Chunk := Chunk.Next; + exit when N_Chunk = null; + if N_Chunk.Last - N_Chunk.First + 1 < Max_Size then + -- Not enough place in this chunk. + Chunk.Next := N_Chunk.Next; + Free (N_Chunk); + if Chunk.Next = null then + S2.Last_Chunk := Chunk; + exit; + end if; + else + Res := N_Chunk.Mem (N_Chunk.First)'Address; + S2.Top := N_Chunk.First + Max_Size; + return Res; + end if; + end loop; + end if; + + -- If not such chunk, allocate a chunk + S2.Top := S2.Last_Chunk.Last + 1; + Chunk := new Chunk_Type (First => S2.Top, + Last => S2.Top + Max_Size - 1); + Chunk.Next := null; + S2.Last_Chunk.Next := Chunk; + S2.Last_Chunk := Chunk; + S2.Top := Chunk.Last + 1; + return Chunk.Mem (Chunk.First)'Address; + end Allocate; + + function Create return Stack2_Ptr is + Res : Stack2_Acc; + Chunk : Chunk_Acc; + begin + Chunk := new Chunk_Type (First => 1, Last => 8 * 1024); + Chunk.Next := null; + Res := new Stack2_Type'(First_Chunk => Chunk, + Last_Chunk => Chunk, + Top => 1); + 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); + + procedure Dump_Stack2 (S : Stack2_Ptr) + is + use Grt.Astdio; + use Grt.Stdio; + use System; + function To_Address is new Ada.Unchecked_Conversion + (Source => Chunk_Acc, Target => Address); + function To_Address is new Ada.Unchecked_Conversion + (Source => Mark_Id, Target => Address); + S2 : Stack2_Acc; + Chunk : Chunk_Acc; + begin + S2 := To_Acc (S); + Put ("Stack 2 at "); + Put (stdout, Address (S)); + New_Line; + Put ("First Chunk at "); + Put (stdout, To_Address (S2.First_Chunk)); + Put (", last chunk at "); + Put (stdout, To_Address (S2.Last_Chunk)); + Put (", top at "); + Put (stdout, To_Address (S2.Top)); + New_Line; + Chunk := S2.First_Chunk; + while Chunk /= null loop + Put ("Chunk "); + Put (stdout, To_Address (Chunk)); + Put (": first: "); + Put (stdout, To_Address (Chunk.First)); + Put (", last: "); + Put (stdout, To_Address (Chunk.Last)); + Put (", len: "); + Put (stdout, To_Address (Chunk.Last - Chunk.First + 1)); + Put (", next = "); + Put (stdout, To_Address (Chunk.Next)); + New_Line; + Chunk := Chunk.Next; + end loop; + end Dump_Stack2; +end Grt.Stack2; diff --git a/src/translate/grt/grt-stack2.ads b/src/translate/grt/grt-stack2.ads new file mode 100644 index 0000000..b3de6b7 --- /dev/null +++ b/src/translate/grt/grt-stack2.ads @@ -0,0 +1,43 @@ +-- GHDL Run Time (GRT) - secondary stack. +-- 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; +with Grt.Types; use Grt.Types; + +-- Secondary stack management. +package Grt.Stack2 is + type Stack2_Ptr is new System.Address; + Null_Stack2_Ptr : constant Stack2_Ptr := Stack2_Ptr (System.Null_Address); + + type Mark_Id is new Integer_Address; + + function Mark (S : Stack2_Ptr) return Mark_Id; + procedure Release (S : Stack2_Ptr; Mark : Mark_Id); + function Allocate (S : Stack2_Ptr; Size : Ghdl_Index_Type) + return System.Address; + function Create return Stack2_Ptr; + + -- Check S is empty. + procedure Check_Empty (S : Stack2_Ptr); +end Grt.Stack2; diff --git a/src/translate/grt/grt-stacks.adb b/src/translate/grt/grt-stacks.adb new file mode 100644 index 0000000..adb008d --- /dev/null +++ b/src/translate/grt/grt-stacks.adb @@ -0,0 +1,43 @@ +-- 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/translate/grt/grt-stacks.ads b/src/translate/grt/grt-stacks.ads new file mode 100644 index 0000000..dd94340 --- /dev/null +++ b/src/translate/grt/grt-stacks.ads @@ -0,0 +1,87 @@ +-- 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/translate/grt/grt-stats.adb b/src/translate/grt/grt-stats.adb new file mode 100644 index 0000000..5bc046d --- /dev/null +++ b/src/translate/grt/grt-stats.adb @@ -0,0 +1,370 @@ +-- GHDL Run Time (GRT) - statistics. +-- 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 System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.Astdio; use Grt.Astdio; +with Grt.Signals; +with Grt.Processes; +with Grt.Types; use Grt.Types; +with Grt.Disp; + +package body Grt.Stats is + type Clock_T is new Integer; + + type Time_Stats is record + Wall : Clock_T; + User : Clock_T; + Sys : Clock_T; + end record; + + -- Number of CLOCK_T per second. + One_Second : Clock_T; + + + -- Get number of seconds per CLOCK_T. + function Get_Clk_Tck return Clock_T; + pragma Import (C, Get_Clk_Tck, "grt_get_clk_tck"); + + -- Get wall, user and system times. + -- This is a binding to times(2). + procedure Get_Times (Wall : Address; User : Address; Sys : Address); + pragma Import (C, Get_Times, "grt_get_times"); + + procedure Get_Stats (Stats : out Time_Stats) + is + begin + Get_Times (Stats.Wall'Address, Stats.User'Address, Stats.Sys'Address); + end Get_Stats; + + function "-" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall - R.Wall, + User => L.User - R.User, + Sys => L.Sys - R.Sys); + end "-"; + + function "+" (L : Time_Stats; R : Time_Stats) return Time_Stats + is + begin + return Time_Stats'(Wall => L.Wall + R.Wall, + User => L.User + R.User, + Sys => L.Sys + R.Sys); + end "+"; + + procedure Put (Stream : FILEs; Val : Clock_T) + is + procedure Fprintf_Clock (Stream : FILEs; A, B : Clock_T); + pragma Import (C, Fprintf_Clock, "__ghdl_fprintf_clock"); + + Sec : Clock_T; + Ms : Clock_T; + begin + Sec := Val / One_Second; + + -- Avoid overflow. + Ms := ((Val mod One_Second) * 1000) / One_Second; + + Fprintf_Clock (Stream, Sec, Ms); + end Put; + + procedure Put (Stream : FILEs; T : Time_Stats) is + begin + Put (Stream, "wall: "); + Put (Stream, T.Wall); + Put (Stream, " user: "); + Put (Stream, T.User); + Put (Stream, " sys: "); + Put (Stream, T.Sys); + end Put; + + type Counter_Kind is (Counter_Elab, Counter_Order, + Counter_Process, Counter_Update, + Counter_Next, Counter_Resume); + + type Counter_Array is array (Counter_Kind) of Time_Stats; + Counters : Counter_Array := (others => (0, 0, 0)); + + Init_Time : Time_Stats; + Last_Counter : Counter_Kind; + Last_Time : Time_Stats; + +-- -- Stats at origin. +-- Start_Time : Time_Stats; +-- End_Elab_Time : Time_Stats; +-- End_Order_Time : Time_Stats; + +-- Start_Proc_Time : Time_Stats; +-- Proc_Times : Time_Stats; + +-- Start_Update_Time : Time_Stats; +-- Update_Times : Time_Stats; + +-- Start_Next_Time_Time : Time_Stats; +-- Next_Time_Times : Time_Stats; + +-- Start_Resume_Time : Time_Stats; +-- Resume_Times : Time_Stats; + +-- Running_Time : Time_Stats; +-- Simu_Time : Time_Stats; + + procedure Start_Elaboration is + begin + One_Second := Get_Clk_Tck; + + Get_Stats (Init_Time); + Last_Time := Init_Time; + Last_Counter := Counter_Elab; + end Start_Elaboration; + + procedure Change_Counter (Cnt : Counter_Kind) + is + New_Time : Time_Stats; + begin + Get_Stats (New_Time); + Counters (Last_Counter) := Counters (Last_Counter) + + (New_Time - Last_Time); + Last_Time := New_Time; + Last_Counter := Cnt; + end Change_Counter; + + procedure Start_Order is + begin + Change_Counter (Counter_Order); + end Start_Order; + + procedure Start_Processes is + begin + Change_Counter (Counter_Process); + end Start_Processes; + + procedure Start_Update is + begin + Change_Counter (Counter_Update); + end Start_Update; + + procedure Start_Next_Time is + begin + Change_Counter (Counter_Next); + end Start_Next_Time; + + procedure Start_Resume is + begin + Change_Counter (Counter_Resume); + end Start_Resume; + + procedure End_Simulation is + begin + Change_Counter (Last_Counter); + end End_Simulation; + + procedure Disp_Signals_Stats + is + use Grt.Signals; + Nbr_No_Drivers : Ghdl_I32; + Nbr_Resolv : Ghdl_I32; + Nbr_Multi_Src : Ghdl_I32; + Nbr_Active : Ghdl_I32; + Nbr_Drivers : Ghdl_I32; + Nbr_Direct_Drivers : Ghdl_I32; + + type Propagation_Kind_Array is array (Propagation_Kind_Type) of Ghdl_I32; + Propag_Count : Propagation_Kind_Array; + + type Mode_Array is array (Mode_Type) of Ghdl_I32; + Mode_Counts : Mode_Array; + + type Mode_Name_Type is array (Mode_Type) of String (1 .. 4); + Mode_Names : constant Mode_Name_Type := (Mode_B1 => "B1: ", + Mode_E8 => "E8: ", + Mode_E32 => "E32:", + Mode_I32 => "I32:", + Mode_I64 => "I64:", + Mode_F64 => "F64:"); + begin + Put (stdout, "Number of simple signals: "); + Put_I32 (stdout, Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + New_Line; + Put (stdout, "Number of signals with projected wave: "); + Put_I32 (stdout, Get_Nbr_Future); + New_Line; + + Nbr_No_Drivers := 0; + Nbr_Resolv := 0; + Nbr_Multi_Src := 0; + Nbr_Active := 0; + Nbr_Drivers := 0; + Nbr_Direct_Drivers := 0; + Mode_Counts := (others => 0); + for I in Sig_Table.First .. Sig_Table.Last loop + declare + Sig : Ghdl_Signal_Ptr; + Trans : Transaction_Acc; + begin + Sig := Sig_Table.Table (I); + if Sig.S.Mode_Sig in Mode_Signal_User then + if Sig.S.Nbr_Drivers = 0 then + Nbr_No_Drivers := Nbr_No_Drivers + 1; + end if; + if Sig.S.Nbr_Drivers + Sig.Nbr_Ports > 1 then + Nbr_Multi_Src := Nbr_Multi_Src + 1; + end if; + if Sig.S.Resolv /= null then + Nbr_Resolv := Nbr_Resolv + 1; + end if; + Nbr_Drivers := Nbr_Drivers + Ghdl_I32 (Sig.S.Nbr_Drivers); + for J in 1 .. Sig.S.Nbr_Drivers loop + Trans := Sig.S.Drivers (J - 1).Last_Trans; + if Trans /= null and then Trans.Kind = Trans_Direct then + Nbr_Direct_Drivers := Nbr_Direct_Drivers + 1; + end if; + end loop; + end if; + Mode_Counts (Sig.Mode) := Mode_Counts (Sig.Mode) + 1; + if Sig.Has_Active then + Nbr_Active := Nbr_Active + 1; + end if; + end; + end loop; + Put (stdout, "Number of non-driven simple signals: "); + Put_I32 (stdout, Nbr_No_Drivers); + New_Line; + Put (stdout, "Number of resolved simple signals: "); + Put_I32 (stdout, Nbr_Resolv); + New_Line; + Put (stdout, "Number of multi-sourced signals: "); + Put_I32 (stdout, Nbr_Multi_Src); + New_Line; + Put (stdout, "Number of signals whose activity is managed: "); + Put_I32 (stdout, Nbr_Active); + New_Line; + Put (stdout, "Number of drivers: "); + Put_I32 (stdout, Nbr_Drivers); + New_Line; + Put (stdout, "Number of direct drivers: "); + Put_I32 (stdout, Nbr_Direct_Drivers); + New_Line; + Put (stdout, "Number of signals per mode:"); + New_Line; + for I in Mode_Type loop + Put (stdout, " "); + Put (stdout, Mode_Names (I)); + Put (stdout, " "); + Put_I32 (stdout, Mode_Counts (I)); + New_Line; + end loop; + New_Line; + + Propag_Count := (others => 0); + for I in Propagation.First .. Propagation.Last loop + Propag_Count (Propagation.Table (I).Kind) := + Propag_Count (Propagation.Table (I).Kind) + 1; + end loop; + + Put (stdout, "Propagation table length: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Signals.Propagation.Last)); + New_Line; + Put (stdout, "Propagation table count:"); + New_Line; + for I in Propagation_Kind_Type loop + if Propag_Count (I) /= 0 then + Put (stdout, " "); + Grt.Disp.Disp_Propagation_Kind (I); + Put (stdout, ": "); + Put_I32 (stdout, Propag_Count (I)); + New_Line; + end if; + end loop; + end Disp_Signals_Stats; + + -- Disp all statistics. + procedure Disp_Stats + is + N : Natural; + begin + Put (stdout, "total: "); + Put (stdout, Last_Time - Init_Time); + New_Line (stdout); + Put (stdout, " elab: "); + Put (stdout, Counters (Counter_Elab)); + New_Line (stdout); + Put (stdout, " internal elab: "); + Put (stdout, Counters (Counter_Order)); + New_Line (stdout); + Put (stdout, " cycle (sum): "); + Put (stdout, Counters (Counter_Process) + Counters (Counter_Resume) + + Counters (Counter_Update) + Counters (Counter_Next)); + New_Line (stdout); + Put (stdout, " processes: "); + Put (stdout, Counters (Counter_Process)); + New_Line (stdout); + Put (stdout, " resume: "); + Put (stdout, Counters (Counter_Resume)); + New_Line (stdout); + Put (stdout, " update: "); + Put (stdout, Counters (Counter_Update)); + New_Line (stdout); + Put (stdout, " next compute: "); + Put (stdout, Counters (Counter_Next)); + New_Line (stdout); + + Disp_Signals_Stats; + + Put (stdout, "Number of delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Delta_Cycles)); + New_Line; + Put (stdout, "Number of non-delta cycles: "); + Put_I32 (stdout, Ghdl_I32 (Processes.Nbr_Cycles)); + New_Line; + + Put (stdout, "Nbr of events: "); + Put_I32 (stdout, Signals.Nbr_Events); + New_Line; + Put (stdout, "Nbr of active: "); + Put_I32 (stdout, Signals.Nbr_Active); + New_Line; + + Put (stdout, "Number of processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Processes)); + New_Line; + Put (stdout, "Number of sensitized processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Sensitized_Processes)); + New_Line; + Put (stdout, "Number of resumed processes: "); + Put_I32 (stdout, Ghdl_I32 (Grt.Processes.Get_Nbr_Resumed_Processes)); + New_Line; + Put (stdout, "Average number of resumed processes per cycle: "); + N := Processes.Nbr_Delta_Cycles + Processes.Nbr_Cycles; + if N = 0 then + Put (stdout, "-"); + else + Put_I32 (stdout, Ghdl_I32 (Processes.Get_Nbr_Resumed_Processes / N)); + end if; + New_Line; + end Disp_Stats; +end Grt.Stats; diff --git a/src/translate/grt/grt-stats.ads b/src/translate/grt/grt-stats.ads new file mode 100644 index 0000000..6f60261 --- /dev/null +++ b/src/translate/grt/grt-stats.ads @@ -0,0 +1,54 @@ +-- GHDL Run Time (GRT) - statistics. +-- 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. + +package Grt.Stats is + -- Entry points to gather statistics. + procedure Start_Elaboration; + procedure Start_Order; + + -- Time in user processes. + procedure Start_Processes; + + + -- Time in next time computation. + procedure Start_Next_Time; + + + -- Time in signals update. + procedure Start_Update; + + + -- Time in process resume + procedure Start_Resume; + + + procedure End_Simulation; + + -- Disp all statistics. + procedure Disp_Stats; +end Grt.Stats; + + + diff --git a/src/translate/grt/grt-std_logic_1164.adb b/src/translate/grt/grt-std_logic_1164.adb new file mode 100644 index 0000000..5be308b --- /dev/null +++ b/src/translate/grt/grt-std_logic_1164.adb @@ -0,0 +1,146 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 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.Lib; + +package body Grt.Std_Logic_1164 is + Assert_DC_Msg : constant String := + "STD_LOGIC_1164: '-' operand for matching ordering operator"; + + Assert_DC_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To, + Length => Assert_DC_Msg'Length)); + + Assert_DC_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_DC_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address)); + + Filename : constant String := "std_logic_1164.vhdl" & NUL; + Loc : aliased constant Ghdl_Location := + (Filename => To_Ghdl_C_String (Filename'Address), + Line => 58, + Col => 3); + + procedure Assert_Not_Match (V : Std_Ulogic) + is + use Grt.Lib; + begin + if V = '-' then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + end Assert_Not_Match; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Eq_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Eq; + + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Not_Table (Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Ne; + + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Match_Lt_Table (Left, Right)); + end Ghdl_Std_Ulogic_Match_Lt; + + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8 + is + Left : constant Std_Ulogic := Std_Ulogic'Val (L); + Right : constant Std_Ulogic := Std_Ulogic'Val (R); + begin + Assert_Not_Match (Left); + Assert_Not_Match (Right); + return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right), + Match_Eq_Table (Left, Right))); + end Ghdl_Std_Ulogic_Match_Le; + + Assert_Arr_Msg : constant String := + "parameters of '?=' array operator are not of the same length"; + + Assert_Arr_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To, + Length => Assert_Arr_Msg'Length)); + + Assert_Arr_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_Arr_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address)); + + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 + is + use Grt.Lib; + L_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (L); + R_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (R); + Res : Std_Ulogic := '1'; + begin + if L_Len /= R_Len then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + for I in 1 .. L_Len loop + Res := And_Table + (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1), + R_Arr (I - 1)))); + end loop; + return Std_Ulogic'Pos (Res); + end Ghdl_Std_Ulogic_Array_Match_Eq; + + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 is + begin + return Std_Ulogic'Pos + (Not_Table (Std_Ulogic'Val + (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len)))); + end Ghdl_Std_Ulogic_Array_Match_Ne; +end Grt.Std_Logic_1164; diff --git a/src/translate/grt/grt-std_logic_1164.ads b/src/translate/grt/grt-std_logic_1164.ads new file mode 100644 index 0000000..4d15695 --- /dev/null +++ b/src/translate/grt/grt-std_logic_1164.ads @@ -0,0 +1,124 @@ +-- GHDL Run Time (GRT) std_logic_1664 subprograms. +-- Copyright (C) 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.Types; use Grt.Types; + +package Grt.Std_Logic_1164 is + type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-'); + + type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic; + type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic; + + -- LRM08 9.2.3 Relational operators + Match_Eq_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUU1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "UXXXXXXX1", + "UXXXXXXX1", + "UX10XX101", + "UX01XX011", + "111111111"); + + Match_Lt_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "UXXXXXXXX", + "UXXXXXXXX", + "UX01XX01X", + "UX00XX00X", + "XXXXXXXXX"); + + And_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UU0UUU0UX", -- U + "UX0XXX0XX", -- X + "000000000", -- 0 + "UX01XX01X", -- 1 + "UX0XXX0XX", -- Z + "UX0XXX0XX", -- W + "000000000", -- L + "UX01XX01X", -- H + "UX0XXX0XX"); -- - + + Or_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUU1UUU1U", -- U + "UXX1XXX1X", -- X + "UX01XX01X", -- 0 + "111111111", -- 1 + "UXX1XXX1X", -- Z + "UXX1XXX1X", -- W + "UX01XX01X", -- L + "111111111", -- H + "UXX1XXX1X"); -- - + + Xor_Table : constant Stdlogic_Table_2d := + --UX01ZWLH- + ("UUUUUUUUU", -- U + "UXXXXXXXX", -- X + "UX01XX01X", -- 0 + "UX10XX10X", -- 1 + "UXXXXXXXX", -- Z + "UXXXXXXXX", -- W + "UX01XX01X", -- L + "UX10XX10X", -- H + "UXXXXXXXX"); -- - + + Not_Table : constant Stdlogic_Table_1d := "UX10XX10X"; + + function Ghdl_Std_Ulogic_Match_Eq (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Ne (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8; + function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8; + -- For Gt and Ge, use Lt and Le with swapped parameters. + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + +private + pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt"); + pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le"); + + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq, + "__ghdl_std_ulogic_array_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne, + "__ghdl_std_ulogic_array_match_ne"); +end Grt.Std_Logic_1164; diff --git a/src/translate/grt/grt-stdio.ads b/src/translate/grt/grt-stdio.ads new file mode 100644 index 0000000..229249a --- /dev/null +++ b/src/translate/grt/grt-stdio.ads @@ -0,0 +1,107 @@ +-- GHDL Run Time (GRT) - stdio binding. +-- 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; +with Grt.C; use Grt.C; + +-- This package provides a thin binding to the stdio.h of the C library. +-- It mimics GNAT package Interfaces.C_Streams. +-- The purpose of this package is to remove dependencies on the GNAT run time. + +package Grt.Stdio is + pragma Preelaborate (Grt.Stdio); + + -- Type FILE *. + type FILEs is new System.Address; + + -- NULL for a stream. + NULL_Stream : constant FILEs; + + -- Predefined streams. + function stdout return FILEs; + function stderr return FILEs; + function stdin return FILEs; + + -- The following subprograms are translation of the C prototypes. + + function fopen (path: chars; mode : chars) return FILEs; + + function fwrite (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fread (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) + return size_t; + + function fputc (c : int; stream : FILEs) return int; + procedure fputc (c : int; stream : FILEs); + + function fputs (s : chars; stream : FILEs) return int; + + function fgetc (stream : FILEs) return int; + function fgets (s : chars; size : int; stream : FILEs) return chars; + function ungetc (c : int; stream : FILEs) return int; + + function fflush (stream : FILEs) return int; + procedure fflush (stream : FILEs); + + function feof (stream : FILEs) return int; + + function ftell (stream : FILEs) return long; + + function fclose (stream : FILEs) return int; + procedure fclose (Stream : FILEs); +private + -- This is a little bit dubious, but this package should be preelaborated, + -- and Null_Address is not static (since defined in the private part + -- of System). + -- I am pretty sure the C definition of NULL is 0. + NULL_Stream : constant FILEs := FILEs (System'To_Address (0)); + + pragma Import (C, fopen); + + pragma Import (C, fwrite); + pragma Import (C, fread); + + pragma Import (C, fputs); + pragma Import (C, fputc); + + pragma Import (C, fgetc); + pragma Import (C, fgets); + pragma Import (C, ungetc); + + pragma Import (C, fflush); + pragma Import (C, feof); + pragma Import (C, ftell); + pragma Import (C, fclose); + + pragma Import (C, stdout, "__ghdl_get_stdout"); + pragma Import (C, stderr, "__ghdl_get_stderr"); + pragma Import (C, stdin, "__ghdl_get_stdin"); +end Grt.Stdio; diff --git a/src/translate/grt/grt-table.adb b/src/translate/grt/grt-table.adb new file mode 100644 index 0000000..36aa999 --- /dev/null +++ b/src/translate/grt/grt-table.adb @@ -0,0 +1,120 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 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 Grt.C; use Grt.C; + +package body Grt.Table is + + -- Maximum index of table before resizing. + Max : Table_Index_Type := Table_Index_Type'Pred (Table_Low_Bound); + + -- Current value of Last + Last_Val : Table_Index_Type; + + function Malloc (Size : size_t) return Table_Ptr; + pragma Import (C, Malloc); + + procedure Free (T : Table_Ptr); + pragma Import (C, Free); + + -- Resize and reallocate the table according to LAST_VAL. + procedure Resize is + function Realloc (T : Table_Ptr; Size : size_t) return Table_Ptr; + pragma Import (C, Realloc); + + New_Size : size_t; + begin + while Max < Last_Val loop + Max := Max + (Max - Table_Low_Bound + 1); + end loop; + + New_Size := size_t ((Max - Table_Low_Bound + 1) * + (Table_Type'Component_Size / Storage_Unit)); + + Table := Realloc (Table, New_Size); + + if Table = null then + raise Storage_Error; + end if; + end Resize; + + procedure Append (New_Val : Table_Component_Type) is + begin + Increment_Last; + Table (Last_Val) := New_Val; + end Append; + + procedure Decrement_Last is + begin + Last_Val := Table_Index_Type'Pred (Last_Val); + end Decrement_Last; + + procedure Free is + begin + Free (Table); + Table := null; + end Free; + + procedure Increment_Last is + begin + Last_Val := Table_Index_Type'Succ (Last_Val); + + if Last_Val > Max then + Resize; + end if; + end Increment_Last; + + function Last return Table_Index_Type is + begin + return Last_Val; + end Last; + + procedure Release is + begin + Max := Last_Val; + Resize; + end Release; + + procedure Set_Last (New_Val : Table_Index_Type) is + begin + if New_Val < Last_Val then + Last_Val := New_Val; + else + Last_Val := New_Val; + + if Last_Val > Max then + Resize; + end if; + end if; + end Set_Last; + +begin + Last_Val := Table_Index_Type'Pred (Table_Low_Bound); + Max := Table_Low_Bound + Table_Index_Type (Table_Initial) - 1; + + Table := Malloc (size_t (Table_Initial * + (Table_Type'Component_Size / Storage_Unit))); +end Grt.Table; diff --git a/src/translate/grt/grt-table.ads b/src/translate/grt/grt-table.ads new file mode 100644 index 0000000..f814eff --- /dev/null +++ b/src/translate/grt/grt-table.ads @@ -0,0 +1,75 @@ +-- GHDL Run Time (GRT) - Resizable array +-- Copyright (C) 2008 - 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. + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type; + Table_Initial : Positive; + +package Grt.Table is + pragma Elaborate_Body; + + type Table_Type is + array (Table_Index_Type range <>) of Table_Component_Type; + subtype Fat_Table_Type is + Table_Type (Table_Low_Bound .. Table_Index_Type'Last); + + -- Thin pointer. + type Table_Ptr is access all Fat_Table_Type; + + -- The table itself. + Table : aliased Table_Ptr := null; + + -- Get the high bound. + function Last return Table_Index_Type; + pragma Inline (Last); + + -- Get the low bound. + First : constant Table_Index_Type := Table_Low_Bound; + + -- Increase the length by 1. + procedure Increment_Last; + pragma Inline (Increment_Last); + + -- Decrease the length by 1. + procedure Decrement_Last; + pragma Inline (Decrement_Last); + + -- Set the last bound. + procedure Set_Last (New_Val : Table_Index_Type); + + -- Release extra memory. + procedure Release; + + -- Free all the memory used by the table. + -- The table won't be useable anymore. + procedure Free; + + -- Append a new element. + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); +end Grt.Table; diff --git a/src/translate/grt/grt-threads.ads b/src/translate/grt/grt-threads.ads new file mode 100644 index 0000000..248f2c4 --- /dev/null +++ b/src/translate/grt/grt-threads.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - threading. +-- Copyright (C) 2005 - 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.Unithread; + +package Grt.Threads renames Grt.Unithread; diff --git a/src/translate/grt/grt-types.ads b/src/translate/grt/grt-types.ads new file mode 100644 index 0000000..fed8225 --- /dev/null +++ b/src/translate/grt/grt-types.ads @@ -0,0 +1,327 @@ +-- GHDL Run Time (GRT) - common types. +-- 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; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; + +package Grt.Types is + pragma Preelaborate (Grt.Types); + + type Ghdl_B1 is new Boolean; + type Ghdl_E8 is new Unsigned_8; + type Ghdl_U32 is new Unsigned_32; + subtype Ghdl_E32 is Ghdl_U32; + type Ghdl_I32 is new Integer_32; + type Ghdl_I64 is new Integer_64; + type Ghdl_U64 is new Unsigned_64; + type Ghdl_F64 is new IEEE_Float_64; + + type Ghdl_Ptr is new Address; + type Ghdl_Index_Type is mod 2 ** 32; + subtype Ghdl_Real is Ghdl_F64; + + type Ghdl_Dir_Type is (Dir_To, Dir_Downto); + for Ghdl_Dir_Type use (Dir_To => 0, Dir_Downto => 1); + for Ghdl_Dir_Type'Size use 8; + + -- Access to an unconstrained string. + type String_Access is access String; + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Name => String_Access, Object => String); + + subtype Std_Integer is Ghdl_I32; + + type Std_Time is new Ghdl_I64; + Bad_Time : constant Std_Time := Std_Time'First; + + type Std_Integer_Trt is record + Left : Std_Integer; + Right : Std_Integer; + Dir : Ghdl_Dir_Type; + Length : Ghdl_Index_Type; + end record; + + subtype Std_Character is Character; + type Std_String_Uncons is array (Ghdl_Index_Type range <>) of Std_Character; + subtype Std_String_Base is Std_String_Uncons (Ghdl_Index_Type); + type Std_String_Basep is access all Std_String_Base; + function To_Std_String_Basep is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Basep); + + type Std_String_Bound is record + Dim_1 : Std_Integer_Trt; + end record; + type Std_String_Boundp is access all Std_String_Bound; + function To_Std_String_Boundp is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Boundp); + + type Std_String is record + Base : Std_String_Basep; + Bounds : Std_String_Boundp; + end record; + type Std_String_Ptr is access all Std_String; + function To_Std_String_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Std_String_Ptr); + + type Std_Bit is ('0', '1'); + type Std_Bit_Vector_Uncons is array (Ghdl_Index_Type range <>) of Std_Bit; + subtype Std_Bit_Vector_Base is Std_Bit_Vector_Uncons (Ghdl_Index_Type); + type Std_Bit_Vector_Basep is access all Std_Bit_Vector_Base; + + -- An unconstrained array. + -- It is in fact a fat pointer to the base and the bounds. + type Ghdl_Uc_Array is record + Base : Address; + Bounds : Address; + end record; + type Ghdl_Uc_Array_Acc is access Ghdl_Uc_Array; + function To_Ghdl_Uc_Array_Acc is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Uc_Array_Acc); + + -- Verilog types. + + type Ghdl_Logic32 is record + Val : Ghdl_U32; + Xz : Ghdl_U32; + end record; + type Ghdl_Logic32_Ptr is access Ghdl_Logic32; + type Ghdl_Logic32_Vec is array (Ghdl_U32) of Ghdl_Logic32; + type Ghdl_Logic32_Vptr is access Ghdl_Logic32_Vec; + + function To_Ghdl_Logic32_Vptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Vptr); + + function To_Ghdl_Logic32_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Logic32_Ptr); + + -- Mimics C strings (NUL ended). + -- Note: this is 1 based. + type Ghdl_C_String is access String (Positive); + NUL : constant Character := Character'Val (0); + + Nl : constant Character := Character'Val (10); -- LF, nl or '\n'. + + function strlen (Str : Ghdl_C_String) return Natural; + pragma Import (C, strlen); + + function Strcmp (L , R : Ghdl_C_String) return Integer; + pragma Import (C, Strcmp); + + function To_Ghdl_C_String is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_C_String); + + -- Str_len. + type String_Ptr is access String (1 .. Natural'Last); + type Ghdl_Str_Len_Type is record + Len : Natural; + Str : String_Ptr; + end record; + -- Same as previous one, but using 'address. + type Ghdl_Str_Len_Address_Type is record + Len : Natural; + Str : Address; + end record; + type Ghdl_Str_Len_Ptr is access constant Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array is array (Natural) of Ghdl_Str_Len_Type; + type Ghdl_Str_Len_Array_Ptr is access all Ghdl_Str_Len_Array; + + -- Location is used for errors/messages. + type Ghdl_Location is record + Filename : Ghdl_C_String; + Line : Integer; + Col : Integer; + end record; + type Ghdl_Location_Ptr is access Ghdl_Location; + function To_Ghdl_Location_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Location_Ptr); + + -- Signal index. + type Sig_Table_Index is new Integer; + + -- A range of signals. + type Sig_Table_Range is record + First, Last : Sig_Table_Index; + end record; + + -- Simple values, used for signals. + type Mode_Type is + (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64); + + type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1; + subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type); + type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base; + function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr); + + type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8; + subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type); + type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base; + function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr); + + type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32; + subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type); + type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base; + function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr); + + type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32; + + type Value_Union (Mode : Mode_Type := Mode_B1) is record + case Mode is + when Mode_B1 => + B1 : Ghdl_B1; + when Mode_E8 => + E8 : Ghdl_E8; + when Mode_E32 => + E32 : Ghdl_E32; + when Mode_I32 => + I32 : Ghdl_I32; + when Mode_I64 => + I64 : Ghdl_I64; + when Mode_F64 => + F64 : Ghdl_F64; + end case; + end record; + pragma Unchecked_Union (Value_Union); + + type Ghdl_Value_Ptr is access Value_Union; + function To_Ghdl_Value_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Value_Ptr); + + -- Ranges. + type Ghdl_Range_B1 is record + Left : Ghdl_B1; + Right : Ghdl_B1; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E8 is record + Left : Ghdl_E8; + Right : Ghdl_E8; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_E32 is record + Left : Ghdl_E32; + Right : Ghdl_E32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I32 is record + Left : Ghdl_I32; + Right : Ghdl_I32; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_I64 is record + Left : Ghdl_I64; + Right : Ghdl_I64; + Dir : Ghdl_Dir_Type; + Len : Ghdl_Index_Type; + end record; + + type Ghdl_Range_F64 is record + Left : Ghdl_F64; + Right : Ghdl_F64; + Dir : Ghdl_Dir_Type; + end record; + + type Ghdl_Range_Type (K : Mode_Type := Mode_B1) is record + case K is + when Mode_B1 => + B1 : Ghdl_Range_B1; + when Mode_E8 => + E8 : Ghdl_Range_E8; + when Mode_E32 => + E32 : Ghdl_Range_E32; + when Mode_I32 => + I32 : Ghdl_Range_I32; + when Mode_I64 => + P64 : Ghdl_Range_I64; + when Mode_F64 => + F64 : Ghdl_Range_F64; + end case; + end record; + pragma Unchecked_Union (Ghdl_Range_Type); + + type Ghdl_Range_Ptr is access all Ghdl_Range_Type; + + function To_Ghdl_Range_Ptr is new Ada.Unchecked_Conversion + (Source => Address, Target => Ghdl_Range_Ptr); + + type Ghdl_Range_Array is array (Ghdl_Index_Type range <>) of Ghdl_Range_Ptr; + + -- Mode of a signal. + type Mode_Signal_Type is + (Mode_Signal, + Mode_Linkage, Mode_Buffer, Mode_Out, Mode_Inout, Mode_In, + Mode_Stable, Mode_Quiet, Mode_Delayed, Mode_Transaction, Mode_Guard, + Mode_Conv_In, Mode_Conv_Out, + Mode_End); + + subtype Mode_Signal_Port is + Mode_Signal_Type range Mode_Linkage .. Mode_In; + + -- Not implicit signals. + subtype Mode_Signal_User is + Mode_Signal_Type range Mode_Signal .. Mode_In; + + -- Implicit signals. + subtype Mode_Signal_Implicit is + Mode_Signal_Type range Mode_Stable .. Mode_Guard; + + subtype Mode_Signal_Forward is + Mode_Signal_Type range Mode_Stable .. Mode_Delayed; + + -- Kind of a signal. + type Kind_Signal_Type is + (Kind_Signal_No, Kind_Signal_Register, Kind_Signal_Bus); + + -- Note: we could use system.storage_elements, but unfortunatly, + -- this doesn't work with pragma no_run_time (gnat 3.15p). + type Integer_Address is mod Memory_Size; + + function To_Address is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Address); + + function To_Integer is new Ada.Unchecked_Conversion + (Source => Address, Target => Integer_Address); + + -- The NOW value. + Current_Time : Std_Time; + -- Copy of Current_Time before updating it. + -- To be used by hooks. + Cycle_Time : Std_Time; + -- The current delta cycle number. + Current_Delta : Integer; +private + pragma Export (C, Current_Time, "__ghdl_now"); +end Grt.Types; diff --git a/src/translate/grt/grt-unithread.adb b/src/translate/grt/grt-unithread.adb new file mode 100644 index 0000000..6acb521 --- /dev/null +++ b/src/translate/grt/grt-unithread.adb @@ -0,0 +1,106 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 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. + +package body Grt.Unithread is + procedure Init is + begin + null; + end Init; + + procedure Finish is + begin + null; + end Finish; + + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc) is + begin + Subprg.all; + end Run_Parallel; + + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr + is + Prev : Ghdl_Signal_Ptr; + begin + Prev := List.all; + List.all := El; + return Prev; + end Atomic_Insert; + + function Atomic_Inc (Val : access Natural) return Natural + is + Res : Natural; + begin + Res := Val.all; + Val.all := Val.all + 1; + return Res; + end Atomic_Inc; + + Current_Process : Process_Acc; + + -- Called by linux.c + function Grt_Get_Current_Process return Process_Acc; + pragma Export (C, Grt_Get_Current_Process); + + function Grt_Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Grt_Get_Current_Process; + + + procedure Set_Current_Process (Proc : Process_Acc) is + begin + Current_Process := Proc; + end Set_Current_Process; + + function Get_Current_Process return Process_Acc is + begin + return Current_Process; + end Get_Current_Process; + + Stack2 : Stack2_Ptr; + + function Get_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; +end Grt.Unithread; diff --git a/src/translate/grt/grt-unithread.ads b/src/translate/grt/grt-unithread.ads new file mode 100644 index 0000000..b35b7be --- /dev/null +++ b/src/translate/grt/grt-unithread.ads @@ -0,0 +1,73 @@ +-- GHDL Run Time (GRT) - mono-thread version. +-- Copyright (C) 2005 - 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.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; + procedure Finish; + + type Parallel_Subprg_Acc is access procedure; + procedure Run_Parallel (Subprg : Parallel_Subprg_Acc); + + -- Return the old value of LIST.all and store EL into LIST.all. + function Atomic_Insert (List : access Ghdl_Signal_Ptr; El : Ghdl_Signal_Ptr) + return Ghdl_Signal_Ptr; + + -- Return the old value. + function Atomic_Inc (Val : access Natural) return Natural; + + -- Set and get the current process being executed by the thread. + 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); +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); + +end Grt.Unithread; diff --git a/src/translate/grt/grt-values.adb b/src/translate/grt/grt-values.adb new file mode 100644 index 0000000..3d703bc --- /dev/null +++ b/src/translate/grt/grt-values.adb @@ -0,0 +1,639 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- 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; +with Grt.Rtis_Utils; + +package body Grt.Values is + + NBSP : constant Character := Character'Val (160); + HT : constant Character := Character'Val (9); + + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean is + begin + return C = ' ' or C = NBSP or C = HT; + end Is_Whitespace; + + -- Increase POS to skip leading whitespace characters, decrease LEN to + -- skip trailing whitespaces in string S. + procedure Remove_Whitespaces (S : Std_String_Basep; + Len : in out Ghdl_Index_Type; + Pos : in out Ghdl_Index_Type) is + begin + -- GHDL: allow several leading whitespace. + while Pos < Len loop + exit when not Is_Whitespace (S (Pos)); + Pos := Pos + 1; + end loop; + + -- GHDL: allow several leading whitespace. + while Len > Pos loop + exit when not Is_Whitespace (S (Len - 1)); + Len := Len - 1; + end loop; + if Pos = Len then + Error_E ("'value: empty string"); + end if; + end Remove_Whitespaces; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character is + begin + if C >= 'A' and then C <= 'Z' then + return Character'Val + (Character'Pos (C) + Character'Pos ('a') - Character'Pos ('A')); + else + return C; + end if; + end To_LC; + + -- Return TRUE iff user string S (POS .. LEN - 1) is equal to REF. + -- Comparaison is case insensitive, but REF must be lowercase (REF is + -- supposed to come from an RTI). + function String_Match (S : Std_String_Basep; + Pos : Ghdl_Index_Type; + Len : Ghdl_Index_Type; + Ref : Ghdl_C_String) return Boolean + is + P : Ghdl_Index_Type; + C : Character; + begin + P := 0; + loop + C := Ref (Natural (P + 1)); + if Pos + P = Len then + -- End of string. + return C = ASCII.NUL; + end if; + if To_LC (S (Pos + P)) /= C or else C = ASCII.NUL then + return False; + end if; + P := P + 1; + end loop; + end String_Match; + + -- Return the value of STR for enumerated type RTI. + function Ghdl_Value_Enum (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + Remove_Whitespaces (S, Len, Pos); + + for I in 0 .. Enum_Rti.Nbr - 1 loop + if String_Match (S, Pos, Len, Enum_Rti.Names (I)) then + return I; + end if; + end loop; + Error_C ("'value: '"); + Error_C_Std (S (Pos .. Len)); + Error_C ("' not in enumeration '"); + Error_C (Enum_Rti.Name); + Error_E ("'"); + end Ghdl_Value_Enum; + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1 + is + begin + return Ghdl_B1'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_B1; + + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8 + is + begin + return Ghdl_E8'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E8; + + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32 + is + begin + return Ghdl_E32'Val (Ghdl_Value_Enum (Str, Rti)); + end Ghdl_Value_E32; + + -- Convert S (INIT_POS .. LEN) to a signed integer. + function Ghdl_Value_I64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_I64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Sep : Character; + Val, D, Base : Ghdl_I64; + Exp : Integer; + begin + C := S (Pos); + + -- Be user friendly. + -- FIXME: reference. + if C = '-' or C = '+' then + Error_E ("'value: leading sign +/- not allowed"); + end if; + + Val := 0; + loop + if C in '0' .. '9' then + Val := Val * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when '#' + | ':' + | 'E' + | 'e' => + exit; + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + + if Pos >= Len then + return Val; + end if; + + if C = '#' or C = ':' then + Base := Val; + Val := 0; + Sep := C; + Pos := Pos + 1; + if Base < 2 or Base > 16 then + Error_E ("'value: bad base"); + end if; + if Pos >= Len then + Error_E ("'value: missing based integer"); + end if; + C := S (Pos); + loop + case C is + when '0' .. '9' => + D := Character'Pos (C) - Character'Pos ('0'); + when 'a' .. 'f' => + D := Character'Pos (C) - Character'Pos ('a') + 10; + when 'A' .. 'F' => + D := Character'Pos (C) - Character'Pos ('A') + 10; + when others => + Error_E ("'value: digit expected"); + end case; + if D >= Base then + Error_E ("'value: digit >= base"); + end if; + Val := Val * Base + D; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + C := S (Pos); + if C = '#' or C = ':' then + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + exit; + elsif C = '_' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after underscore"); + end if; + C := S (Pos); + end if; + end loop; + else + Base := 10; + end if; + + -- Handle exponent. + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '+' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after sign"); + end if; + C := S (Pos); + elsif C = '-' then + Error_E ("'value: negativ exponent not allowed"); + end if; + Exp := 0; + loop + if C in '0' .. '9' then + Exp := Exp * 10 + Character'Pos (C) - Character'Pos ('0'); + Pos := Pos + 1; + exit when Pos >= Len; + C := S (Pos); + else + Error_E ("'value: decimal digit expected"); + end if; + case C is + when '_' => + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: trailing underscore"); + end if; + C := S (Pos); + when ' ' + | NBSP + | HT => + Pos := Pos + 1; + exit; + when others => + null; + end case; + end loop; + while Exp > 0 loop + if Exp mod 2 = 1 then + Val := Val * Base; + end if; + Exp := Exp / 2; + Base := Base * Base; + end loop; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + return Val; + end Ghdl_Value_I64; + + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading [and trailing] whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_I64 (S, Len, Pos); + end Ghdl_Value_I64; + + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32 + is + begin + return Ghdl_I32 (Ghdl_Value_I64 (Str)); + end Ghdl_Value_I32; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (S : Std_String_Basep; + Len : Ghdl_Index_Type; + Init_Pos : Ghdl_Index_Type) + return Ghdl_F64 + is + Pos : Ghdl_Index_Type := Init_Pos; + C : Character; + Is_Negative, Is_Neg_Exp : Boolean := False; + Base : Ghdl_F64; + Intg : Ghdl_I32; + Val, Df : Ghdl_F64; + Sep : Character; + FrcExp : Ghdl_F64; + begin + C := S (Pos); + if C = '-' then + Is_Negative := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + + if Pos >= Len then + Error_E ("'value: decimal digit expected"); + end if; + + -- Read Integer-or-Base part (may be optional) + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + elsif C /= '_' then + exit; + end if; + Pos := Pos + 1; + end loop; + + if Pos = Len then + return Ghdl_F64 (Intg); + end if; + + -- Special case: base was specified + if C = '#' or C = ':' then + if Intg < 2 or Intg > 16 then + Error_E ("'value: bad base"); + end if; + Base := Ghdl_F64 (Intg); + Val := 0.0; + Sep := C; + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: missing based decimal"); + end if; + + -- Get the Integer part of the Value + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0') ); + when 'A' .. 'F' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + if Df >= Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val * Base + Df; + end if; + Pos := Pos + 1; + end loop; + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + else + Base := 10.0; + Sep := ' '; + Val := Ghdl_F64 (Intg); + end if; + + -- Handle the Fractional part + if C = '.' then + Pos := Pos + 1; + FrcExp := 1.0; + while Pos < Len loop + C := S (Pos); + case C is + when '0' .. '9' => + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('0')); + when 'A' .. 'F' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('A') + 10); + when 'a' .. 'f' => + exit when Sep = ' '; + Df := Ghdl_F64 (Character'Pos (C) - Character'Pos('a') + 10); + when others => + exit; + end case; + if C /= '_' then + FrcExp := FrcExp / Base; + if Df > Base then + Error_E ("'value: digit greater than base"); + end if; + Val := Val + Df * FrcExp; + end if; + Pos := Pos + 1; + end loop; + end if; + + -- If base was specified, we must find here the end marker + if Sep /= ' ' then + if Pos >= Len then + Error_E ("'value: missing end sign number"); + end if; + if C /= Sep then + Error_E ("'value: sign number mismatch"); + end if; + Pos := Pos + 1; + end if; + + -- Handle exponent + if Pos < Len then + C := S (Pos); + if C = 'e' or C = 'E' then + Pos := Pos + 1; + if Pos >= Len then + Error_E ("'value: no character after exponent"); + end if; + C := S (Pos); + if C = '-' then + Is_Neg_Exp := True; + Pos := Pos + 1; + elsif C = '+' then + Pos := Pos + 1; + end if; + Intg := 0; + while Pos < Len loop + C := S (Pos); + if C in '0' .. '9' then + Intg := Intg * 10 + Character'Pos (C) - Character'Pos ('0'); + else + exit; + end if; + Pos := Pos + 1; + end loop; + -- This Exponentiation method is sub-optimal, + -- but it does not depend on any library + FrcExp := 1.0; + if Is_Neg_Exp then + while Intg > 0 loop + FrcExp := FrcExp / 10.0; + Intg := Intg - 1; + end loop; + else + while Intg > 0 loop + FrcExp := FrcExp * 10.0; + Intg := Intg - 1; + end loop; + end if; + Val := Val * FrcExp; + end if; + end if; + + if Pos /= Len then + Error_E ("'value: trailing characters after blank"); + end if; + + if Is_Negative then + Val := -Val; + end if; + + return Val; + end Ghdl_Value_F64; + + -- From patch attached to https://gna.org/bugs/index.php?18352 + -- thanks to Christophe Curis https://gna.org/users/lobotomy + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Pos : Ghdl_Index_Type := 0; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + -- + -- GHDL: allow several leading whitespace. + Remove_Whitespaces (S, Len, Pos); + + return Ghdl_Value_F64 (S, Len, Pos); + end Ghdl_Value_F64; + + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type) + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + begin + -- LRM 14.1 + -- Leading and trailing whitespace is allowed and ignored. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Split between abstract literal (optionnal) and unit name. + Lit_End := Lit_Pos; + Is_Real := False; + while Lit_End < Len loop + exit when Is_Whitespace (S (Lit_End)); + if S (Lit_End) = '.' then + Is_Real := True; + end if; + Lit_End := Lit_End + 1; + end loop; + if Lit_End = Len then + -- No literal + Unit_Pos := Lit_Pos; + Lit_End := 0; + else + Unit_Pos := Lit_End + 1; + while Unit_Pos < Len loop + exit when not Is_Whitespace (S (Unit_Pos)); + Unit_Pos := Unit_Pos + 1; + end loop; + end if; + end Ghdl_Value_Physical_Split; + + function Ghdl_Value_Physical_Type (Str : Std_String_Ptr; + Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + S : constant Std_String_Basep := Str.Base; + Len : Ghdl_Index_Type := Str.Bounds.Dim_1.Length; + Unit_Pos : Ghdl_Index_Type; + Lit_Pos : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + + Found_Real : Boolean; + + Phys_Rti : constant Ghdl_Rtin_Type_Physical_Acc := + To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Multiple : Ghdl_Rti_Access; + Mult : Ghdl_I64; + begin + -- Remove trailing whitespaces. FIXME: also called in physical_split. + Lit_Pos := 0; + Remove_Whitespaces (S, Len, Lit_Pos); + + -- Extract literal and unit + Ghdl_Value_Physical_Split (Str, Found_Real, Lit_Pos, Lit_End, Unit_Pos); + + -- Find unit value + Multiple := null; + for i in 0 .. Phys_Rti.Nbr - 1 loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Phys_Rti.Units (i)); + if String_Match (S, Unit_Pos, Len, Unit_Name) then + Multiple := Phys_Rti.Units (i); + exit; + end if; + end loop; + if Multiple = null then + Error_C ("'value: unit '"); + Error_C_Std (S (Unit_Pos .. Len - 1)); + Error_C ("' not in physical type '"); + Error_C (Phys_Rti.Name); + Error_E ("'"); + end if; + + Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti); + + if Lit_End = 0 then + return Mult; + else + if Found_Real then + return Ghdl_I64 + (Ghdl_Value_F64 (S, Lit_End, Lit_Pos) * Ghdl_F64 (Mult)); + else + return Ghdl_Value_I64 (S, Lit_End, Lit_Pos) * Mult; + end if; + end if; + end Ghdl_Value_Physical_Type; + + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P64 then + Error_E ("Physical_Type_64'value: incorrect RTI"); + end if; + return Ghdl_Value_Physical_Type (Str, Rti); + end Ghdl_Value_P64; + + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32 + is + begin + if Rti.Kind /= Ghdl_Rtik_Type_P32 then + Error_E ("Physical_Type_32'value: incorrect RTI"); + end if; + return Ghdl_I32 (Ghdl_Value_Physical_Type (Str, Rti)); + end Ghdl_Value_P32; + +end Grt.Values; diff --git a/src/translate/grt/grt-values.ads b/src/translate/grt/grt-values.ads new file mode 100644 index 0000000..8df8c3f --- /dev/null +++ b/src/translate/grt/grt-values.ads @@ -0,0 +1,69 @@ +-- GHDL Run Time (GRT) - 'value subprograms. +-- 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.Types; use Grt.Types; +with Grt.Rtis; use Grt.Rtis; + +package Grt.Values is + -- Return True IFF C is a whitespace character (as defined in LRM93 14.3) + function Is_Whitespace (C : in Character) return Boolean; + + -- Convert C to lowercase. + function To_LC (C : in Character) return Character; + + -- Extract position of numeric literal and unit in string STR. + -- Set IS_REAL if the unit is a real number (presence of '.'). + -- Set UNIT_POS to the position of the first character of the unit name. + -- Set LIT_POS to the position of the first character of the numeric + -- literal (after whitespaces are skipped). + -- Set LIT_END to the position of the next character of the numeric lit. + procedure Ghdl_Value_Physical_Split (Str : Std_String_Ptr; + Is_Real : out Boolean; + Lit_Pos : out Ghdl_Index_Type; + Lit_End : out Ghdl_Index_Type; + Unit_Pos : out Ghdl_Index_Type); + + function Ghdl_Value_B1 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_B1; + function Ghdl_Value_E8 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E8; + function Ghdl_Value_E32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_E32; + function Ghdl_Value_I32 (Str : Std_String_Ptr) return Ghdl_I32; + function Ghdl_Value_I64 (Str : Std_String_Ptr) return Ghdl_I64; + function Ghdl_Value_F64 (Str : Std_String_Ptr) return Ghdl_F64; + function Ghdl_Value_P64 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I64; + function Ghdl_Value_P32 (Str : Std_String_Ptr; Rti : Ghdl_Rti_Access) + return Ghdl_I32; +private + pragma Export (Ada, Ghdl_Value_B1, "__ghdl_value_b1"); + pragma Export (C, Ghdl_Value_E8, "__ghdl_value_e8"); + pragma Export (C, Ghdl_Value_E32, "__ghdl_value_e32"); + pragma Export (C, Ghdl_Value_I32, "__ghdl_value_i32"); + pragma Export (C, Ghdl_Value_I64, "__ghdl_value_i64"); + pragma Export (C, Ghdl_Value_F64, "__ghdl_value_f64"); + pragma Export (C, Ghdl_Value_P64, "__ghdl_value_p64"); + pragma Export (C, Ghdl_Value_P32, "__ghdl_value_p32"); +end Grt.Values; diff --git a/src/translate/grt/grt-vcd.adb b/src/translate/grt/grt-vcd.adb new file mode 100644 index 0000000..d4a9ea0 --- /dev/null +++ b/src/translate/grt/grt-vcd.adb @@ -0,0 +1,845 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- 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 Interfaces; +with Grt.Stdio; use Grt.Stdio; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.C; use Grt.C; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Types; use Grt.Rtis_Types; +with Grt.Vstrings; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vcd is + -- If TRUE, put $date in vcd file. + -- Can be set to FALSE to make vcd comparaison easier. + Flag_Vcd_Date : Boolean := True; + + Stream : FILEs; + + procedure My_Vcd_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Stream); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Stream); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + fclose (Stream); + Stream := NULL_Stream; + end My_Vcd_Close; + + -- VCD filename. + -- Stream corresponding to the VCD filename. + --Vcd_Stream : FILEs; + + -- Index type of the table of vcd variables to dump. + type Vcd_Index_Type is new Integer; + + -- Return TRUE if OPT is an option for VCD. + function Vcd_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Mode : constant String := "wt" & NUL; + Vcd_Filename : String_Access; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vcd" then + return False; + end if; + if Opt'Length = 12 and then Opt (F + 5 .. F + 11) = "-nodate" then + Flag_Vcd_Date := False; + return True; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + if Vcd_Close /= null then + Error ("--vcd: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 6 + 1); + Vcd_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + if Vcd_Filename.all = "-" & NUL then + Stream := stdout; + else + Stream := fopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcd_Option; + + procedure Vcd_Help is + begin + Put_Line (" --vcd=FILENAME dump signal values into a VCD file"); + Put_Line (" --vcd-nodate do not write date in VCD file"); + end Vcd_Help; + + procedure Vcd_Newline is + begin + Vcd_Putc (Nl); + end Vcd_Newline; + + procedure Vcd_Putline (Str : String) is + begin + Vcd_Put (Str); + Vcd_Newline; + end Vcd_Putline; + +-- procedure Vcd_Put (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len (Vcd_Stream, Str); +-- end Vcd_Put; + + procedure Vcd_Put_I32 (V : Ghdl_I32) + is + Str : String (1 .. 11); + First : Natural; + begin + Vstrings.To_String (Str, First, V); + Vcd_Put (Str (First .. Str'Last)); + end Vcd_Put_I32; + + procedure Vcd_Put_Idcode (N : Vcd_Index_Type) + is + Str : String (1 .. 8); + V, R : Vcd_Index_Type; + L : Natural; + begin + L := 0; + V := N; + loop + R := V mod 93; + V := V / 93; + L := L + 1; + Str (L) := Character'Val (33 + R); + exit when V = 0; + end loop; + Vcd_Put (Str (1 .. L)); + end Vcd_Put_Idcode; + + procedure Vcd_Put_Name (Obj : VhpiHandleT) + is + Name : String (1 .. 128); + Name_Len : Integer; + begin + Vhpi_Get_Str (VhpiNameP, Obj, Name, Name_Len); + if Name_Len <= Name'Last then + Vcd_Put (Name (1 .. Name_Len)); + else + -- Truncate. + Vcd_Put (Name); + end if; + end Vcd_Put_Name; + + procedure Vcd_Put_End is + begin + Vcd_Putline ("$end"); + end Vcd_Put_End; + + -- Called before elaboration. + procedure Vcd_Init + is + begin + if Vcd_Close = null then + return; + end if; + if Flag_Vcd_Date then + Vcd_Putline ("$date"); + Vcd_Put (" "); + declare + type time_t is new Interfaces.Integer_64; + Cur_Time : time_t; + + function time (Addr : Address) return time_t; + pragma Import (C, time); + + function ctime (Timep: Address) return Ghdl_C_String; + pragma Import (C, ctime); + + Ct : Ghdl_C_String; + begin + Cur_Time := time (Null_Address); + Ct := ctime (Cur_Time'Address); + for I in Positive loop + exit when Ct (I) = NUL; + Vcd_Putc (Ct (I)); + end loop; + -- Note: ctime already append a LF. + end; + Vcd_Put_End; + end if; + Vcd_Putline ("$version"); + Vcd_Putline (" GHDL v0"); + Vcd_Put_End; + Vcd_Putline ("$timescale"); + Vcd_Putline (" 1 fs"); + Vcd_Put_End; + end Vcd_Init; + + package Vcd_Table is new Grt.Table + (Table_Component_Type => Verilog_Wire_Info, + Table_Index_Type => Vcd_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Vcd.Avhpi_Error!"); + null; + end Avhpi_Error; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rti_Access) return Vcd_Var_Kind + is + Rti1 : Ghdl_Rti_Access; + begin + if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then + Rti1 := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; + else + Rti1 := Rti; + end if; + + if Rti1 = Std_Standard_Boolean_RTI_Ptr then + return Vcd_Bool; + end if; + if Rti1 = Std_Standard_Bit_RTI_Ptr then + return Vcd_Bit; + end if; + if Rti1 = Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr then + return Vcd_Stdlogic; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_I32 then + return Vcd_Integer32; + end if; + if Rti1.Kind = Ghdl_Rtik_Type_F64 then + return Vcd_Float64; + end if; + return Vcd_Bad; + end Rti_To_Vcd_Kind; + + function Rti_To_Vcd_Kind (Rti : Ghdl_Rtin_Type_Array_Acc) + return Vcd_Var_Kind + is + It : Ghdl_Rti_Access; + begin + if Rti.Nbr_Dim /= 1 then + return Vcd_Bad; + end if; + It := Rti.Indexes (0); + if It.Kind /= Ghdl_Rtik_Subtype_Scalar then + return Vcd_Bad; + end if; + if To_Ghdl_Rtin_Subtype_Scalar_Acc (It).Basetype.Kind + /= Ghdl_Rtik_Type_I32 + then + return Vcd_Bad; + end if; + case Rti_To_Vcd_Kind (Rti.Element) is + when Vcd_Bit => + return Vcd_Bitvector; + when Vcd_Stdlogic => + return Vcd_Stdlogic_Vector; + when others => + return Vcd_Bad; + end case; + end Rti_To_Vcd_Kind; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; Info : out Verilog_Wire_Info) + is + Sig_Type : VhpiHandleT; + Rti : Ghdl_Rti_Access; + Error : AvhpiErrorT; + Sig_Addr : Address; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Rti := Avhpi_Get_Rti (Sig_Type); + Sig_Addr := Avhpi_Get_Address (Sig); + Info.Kind := Vcd_Bad; + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Subtype_Scalar => + Info.Kind := Rti_To_Vcd_Kind (Rti); + Info.Addr := Sig_Addr; + Info.Irange := null; + when Ghdl_Rtik_Subtype_Array => + declare + St : Ghdl_Rtin_Subtype_Array_Acc; + begin + St := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Info.Kind := Rti_To_Vcd_Kind (St.Basetype); + Info.Addr := Sig_Addr; + Info.Irange := To_Ghdl_Range_Ptr + (Loc_To_Addr (St.Common.Depth, St.Bounds, + Avhpi_Get_Context (Sig))); + end; + when Ghdl_Rtik_Type_Array => + declare + Uc : Ghdl_Uc_Array_Acc; + begin + Info.Kind := Rti_To_Vcd_Kind + (To_Ghdl_Rtin_Type_Array_Acc (Rti)); + Uc := To_Ghdl_Uc_Array_Acc (Sig_Addr); + Info.Addr := Uc.Base; + Info.Irange := To_Ghdl_Range_Ptr (Uc.Bounds); + end; + when others => + Info.Irange := null; + end case; + + -- Do not allow null-array. + if Info.Irange /= null and then Info.Irange.I32.Len = 0 then + Info.Kind := Vcd_Bad; + Info.Irange := null; + return; + end if; + + if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then + case Vhpi_Get_Mode (Sig) is + when VhpiInMode + | VhpiInoutMode + | VhpiBufferMode + | VhpiLinkageMode => + Info.Val := Vcd_Effective; + when VhpiOutMode => + Info.Val := Vcd_Driving; + when VhpiErrorMode => + Info.Kind := Vcd_Bad; + end case; + else + Info.Val := Vcd_Effective; + end if; + end Get_Verilog_Wire; + + procedure Add_Signal (Sig : VhpiHandleT) + is + N : Vcd_Index_Type; + Vcd_El : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Sig, Vcd_El); + + if Vcd_El.Kind = Vcd_Bad then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is not handled"); + --Vcd_Put (Ghdl_Type_Kind'Image (Desc.Kind)); + Vcd_Putc (' '); + Vcd_Put_End; + return; + else + Vcd_Table.Increment_Last; + N := Vcd_Table.Last; + + Vcd_Table.Table (N) := Vcd_El; + Vcd_Put ("$var "); + case Vcd_El.Kind is + when Vcd_Integer32 => + Vcd_Put ("integer 32"); + when Vcd_Float64 => + Vcd_Put ("real 64"); + when Vcd_Bool + | Vcd_Bit + | Vcd_Stdlogic => + Vcd_Put ("reg 1"); + when Vcd_Bitvector + | Vcd_Stdlogic_Vector => + Vcd_Put ("reg "); + Vcd_Put_I32 (Ghdl_I32 (Vcd_El.Irange.I32.Len)); + when Vcd_Bad => + null; + end case; + Vcd_Putc (' '); + Vcd_Put_Idcode (N); + Vcd_Putc (' '); + Vcd_Put_Name (Sig); + if Vcd_El.Irange /= null then + Vcd_Putc ('['); + Vcd_Put_I32 (Vcd_El.Irange.I32.Left); + Vcd_Putc (':'); + Vcd_Put_I32 (Vcd_El.Irange.I32.Right); + Vcd_Putc (']'); + end if; + Vcd_Putc (' '); + Vcd_Put_End; + if Boolean'(False) then + Vcd_Put ("$comment "); + Vcd_Put_Name (Sig); + Vcd_Put (" is "); + case Vcd_El.Val is + when Vcd_Effective => + Vcd_Put ("effective "); + when Vcd_Driving => + Vcd_Put ("driving "); + end case; + Vcd_Put_End; + end if; + end if; + end Add_Signal; + + procedure Vcd_Put_Hierarchy (Inst : VhpiHandleT) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Add_Signal (Decl); + when others => + null; + end case; + end loop; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Vcd_Put ("$scope module "); + Vcd_Put_Name (Decl); + Vcd_Putc (' '); + Vcd_Put_End; + Vcd_Put_Hierarchy (Decl); + Vcd_Put ("$upscope "); + Vcd_Put_End; + when others => + null; + end case; + end loop; + + end Vcd_Put_Hierarchy; + + procedure Vcd_Put_Bit (V : Ghdl_B1) + is + C : Character; + begin + if V then + C := '1'; + else + C := '0'; + end if; + Vcd_Putc (C); + end Vcd_Put_Bit; + + procedure Vcd_Put_Stdlogic (V : Ghdl_E8) + is + type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character; + -- "UX01ZWLH-" + -- Map_Vlg : constant Map_Type := "xx01zz01x"; + Map_Std : constant Map_Type := "UX01ZWLH-"; + begin + if V not in Map_Type'Range then + Vcd_Putc ('?'); + else + Vcd_Putc (Map_Std (V)); + end if; + end Vcd_Put_Stdlogic; + + procedure Vcd_Put_Integer32 (V : Ghdl_U32) + is + Val : Ghdl_U32; + N : Natural; + begin + Val := V; + N := 32; + while N > 1 loop + exit when (Val and 16#8000_0000#) /= 0; + Val := Val * 2; + N := N - 1; + end loop; + + while N > 0 loop + if (Val and 16#8000_0000#) /= 0 then + Vcd_Putc ('1'); + else + Vcd_Putc ('0'); + end if; + Val := Val * 2; + N := N - 1; + end loop; + end Vcd_Put_Integer32; + + -- Using the floor attribute of Ghdl_F64 will result on a link error while + -- trying to simulate a design. So it was needed to create a floor function + function Digit_Floor (V : Ghdl_F64) return Ghdl_I32 + is + Var : Ghdl_I32; + begin + -- V is always positive here and only of interest when it is a digit + if V > 10.0 then + return -1; + else + Var := Ghdl_I32(V-0.5); --Ghdl_I32 rounds to the nearest integer + -- The rounding made by Ghdl_I32 is asymetric : + -- 0.5 will be rounded to 1, but -0.5 to -1 instead of 0 + if Var > 0 then + return Var; + else + return 0; + end if; + end if; + end Digit_Floor; + + procedure Vcd_Put_Float64 (V : Ghdl_F64) + is + Val_tmp, Fact : Ghdl_F64; + Digit, Exp, Delta_Exp, N_Exp : Ghdl_I32; + -- + begin + Exp := 0; + if V /= V then + Vcd_Put("NaN"); + return; + end if; + if V < 0.0 then + Vcd_Putc ('-'); + Val_tmp := -V; + elsif V = 0.0 then + Vcd_Put("0.0"); + return; + else + Val_tmp := V; + end if; + if Val_tmp > Ghdl_F64'Last then + Vcd_Put("Inf"); + return; + elsif Val_tmp < 1.0 then + Fact := 10.0; + Delta_Exp := -1; + else + Fact := 0.1; + Delta_Exp := 1; + end if; + + -- Seek the first digit + loop + Digit := Digit_Floor(Val_tmp); + if Digit > 0 then + exit; + end if; + Exp := Exp + Delta_Exp; + Val_tmp := Val_tmp * Fact; + end loop; + Vcd_Putc(Character'Val(Digit + 48)); + Vcd_Putc('.'); + for i in 0..4 loop -- 5 digits displayed after the point + Val_tmp := abs(Val_tmp - Ghdl_F64(Digit))*10.0; + Digit := Digit_Floor(Val_tmp); + Vcd_Putc(Character'Val(Digit + 48)); + end loop; + Vcd_Putc('E'); + if Exp < 0 then + Vcd_Putc('-'); + Exp := -Exp; + end if; + N_Exp := 100; + while N_Exp > 0 loop + Vcd_Putc(Character'Val(Exp/N_Exp + 48)); + Exp := Exp mod N_Exp; + N_Exp := N_Exp/10; + end loop; + end Vcd_Put_Float64; + + procedure Vcd_Put_Var (I : Vcd_Index_Type) + is + Addr : Address; + V : Verilog_Wire_Info renames Vcd_Table.Table (I); + Len : Ghdl_Index_Type; + begin + Addr := V.Addr; + if V.Irange = null then + Len := 1; + else + Len := V.Irange.I32.Len; + end if; + case V.Val is + when Vcd_Effective => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(0).Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(0).Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 (To_Signal_Arr_Ptr (Addr)(0).Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0).Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit (To_Signal_Arr_Ptr (Addr)(J).Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic (To_Signal_Arr_Ptr (Addr)(J).Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case V.Kind is + when Vcd_Bit + | Vcd_Bool => + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.B1); + when Vcd_Stdlogic => + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E8); + when Vcd_Integer32 => + Vcd_Putc ('b'); + Vcd_Put_Integer32 + (To_Signal_Arr_Ptr (Addr)(0).Driving_Value.E32); + Vcd_Putc (' '); + when Vcd_Float64 => + Vcd_Putc ('r'); + Vcd_Put_Float64 (To_Signal_Arr_Ptr (Addr)(0) + .Driving_Value.F64); + Vcd_Putc (' '); + when Vcd_Bitvector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Bit + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.B1); + end loop; + Vcd_Putc (' '); + when Vcd_Stdlogic_Vector => + Vcd_Putc ('b'); + for J in 0 .. Len - 1 loop + Vcd_Put_Stdlogic + (To_Signal_Arr_Ptr (Addr)(J).Driving_Value.E8); + end loop; + Vcd_Putc (' '); + when Vcd_Bad => + null; + end case; + end case; + Vcd_Put_Idcode (I); + Vcd_Newline; + end Vcd_Put_Var; + + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean + is + Len : Ghdl_Index_Type; + begin + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Event = Last then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if To_Signal_Arr_Ptr (Info.Addr)(J).Last_Active = Last + then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + end case; + return False; + end Verilog_Wire_Changed; + + procedure Vcd_Put_Time + is + Str : String (1 .. 21); + First : Natural; + begin + Vcd_Putc ('#'); + Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time)); + Vcd_Put (Str (First .. Str'Last)); + Vcd_Newline; + end Vcd_Put_Time; + + procedure Vcd_Cycle; + + -- Called after elaboration. + procedure Vcd_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Vcd_Close = null then + return; + end if; + + -- Be sure the RTI of std_ulogic is set. + Search_Types_RTI; + + -- Put hierarchy. + Get_Root_Inst (Root); + Vcd_Put_Hierarchy (Root); + + -- End of header. + Vcd_Put ("$enddefinitions "); + Vcd_Put_End; + + Register_Cycle_Hook (Vcd_Cycle'Access); + end Vcd_Start; + + -- Called before each non delta cycle. + procedure Vcd_Cycle is + begin + -- Disp values. + Vcd_Put_Time; + if Cycle_Time = 0 then + -- Disp all values. + for I in Vcd_Table.First .. Vcd_Table.Last loop + Vcd_Put_Var (I); + end loop; + else + -- Disp only values changed. + for I in Vcd_Table.First .. Vcd_Table.Last loop + if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then + Vcd_Put_Var (I); + end if; + end loop; + end if; + end Vcd_Cycle; + + -- Called at the end of the simulation. + procedure Vcd_End is + begin + if Vcd_Close /= null then + Vcd_Close.all; + end if; + end Vcd_End; + + Vcd_Hooks : aliased constant Hooks_Type := + (Option => Vcd_Option'Access, + Help => Vcd_Help'Access, + Init => Vcd_Init'Access, + Start => Vcd_Start'Access, + Finish => Vcd_End'Access); + + procedure Register is + begin + Register_Hooks (Vcd_Hooks'Access); + end Register; +end Grt.Vcd; diff --git a/src/translate/grt/grt-vcd.ads b/src/translate/grt/grt-vcd.ads new file mode 100644 index 0000000..ed015af --- /dev/null +++ b/src/translate/grt/grt-vcd.ads @@ -0,0 +1,65 @@ +-- GHDL Run Time (GRT) - VCD generator. +-- 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 Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vcd is + -- Abstract type for IO. + type Vcd_Put_Acc is access procedure (Str : String); + type Vcd_Putc_Acc is access procedure (C : Character); + type Vcd_Close_Acc is access procedure; + + Vcd_Put : Vcd_Put_Acc; + Vcd_Putc : Vcd_Putc_Acc; + Vcd_Close : Vcd_Close_Acc; + + type Vcd_Var_Kind is (Vcd_Bad, + Vcd_Bool, + Vcd_Integer32, + Vcd_Float64, + Vcd_Bit, Vcd_Stdlogic, + Vcd_Bitvector, Vcd_Stdlogic_Vector); + + -- Which value to be displayed: effective or driving (for out signals). + type Vcd_Value_Kind is (Vcd_Effective, Vcd_Driving); + + type Verilog_Wire_Info is record + Addr : Address; + Irange : Ghdl_Range_Ptr; + Kind : Vcd_Var_Kind; + Val : Vcd_Value_Kind; + end record; + + procedure Get_Verilog_Wire (Sig : VhpiHandleT; + Info : out Verilog_Wire_Info); + + -- Return TRUE if last change time of the wire described by INFO is LAST. + function Verilog_Wire_Changed (Info : Verilog_Wire_Info; + Last : Std_Time) + return Boolean; + + procedure Register; +end Grt.Vcd; diff --git a/src/translate/grt/grt-vcdz.adb b/src/translate/grt/grt-vcdz.adb new file mode 100644 index 0000000..8e1ceb6 --- /dev/null +++ b/src/translate/grt/grt-vcdz.adb @@ -0,0 +1,116 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 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.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Types; use Grt.Types; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Zlib; use Grt.Zlib; +with Grt.C; use Grt.C; + +package body Grt.Vcdz is + Stream : gzFile; + + procedure My_Vcd_Put (Str : String) + is + R : int; + pragma Unreferenced (R); + begin + R := gzwrite (Stream, Str'Address, Str'Length); + end My_Vcd_Put; + + procedure My_Vcd_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := gzputc (Stream, Character'Pos (C)); + end My_Vcd_Putc; + + procedure My_Vcd_Close is + begin + gzclose (Stream); + Stream := NULL_gzFile; + end My_Vcd_Close; + + -- VCD filename. + + -- Return TRUE if OPT is an option for VCD. + function Vcdz_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + Vcd_Filename : String_Access := null; + Mode : constant String := "wb" & NUL; + begin + if Opt'Length < 7 or else Opt (F .. F + 6) /= "--vcdgz" then + return False; + end if; + if Opt'Length > 7 and then Opt (F + 7) = '=' then + if Vcd_Close /= null then + Error ("--vcdgz: file already set"); + return True; + end if; + + -- Add an extra NUL character. + Vcd_Filename := new String (1 .. Opt'Length - 8 + 1); + Vcd_Filename (1 .. Opt'Length - 8) := Opt (F + 8 .. Opt'Last); + Vcd_Filename (Vcd_Filename'Last) := NUL; + + Stream := gzopen (Vcd_Filename.all'Address, Mode'Address); + if Stream = NULL_gzFile then + Error_C ("cannot open "); + Error_E (Vcd_Filename (Vcd_Filename'First + .. Vcd_Filename'Last - 1)); + return True; + end if; + Vcd_Putc := My_Vcd_Putc'Access; + Vcd_Put := My_Vcd_Put'Access; + Vcd_Close := My_Vcd_Close'Access; + return True; + else + return False; + end if; + end Vcdz_Option; + + procedure Vcdz_Help is + begin + Put_Line + (" --vcdgz=FILENAME dump signal values into a VCD gzip'ed file"); + end Vcdz_Help; + + Vcdz_Hooks : aliased constant Hooks_Type := + (Option => Vcdz_Option'Access, + Help => Vcdz_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Proc_Hook_Nil'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Vcdz_Hooks'Access); + end Register; +end Grt.Vcdz; diff --git a/src/translate/grt/grt-vcdz.ads b/src/translate/grt/grt-vcdz.ads new file mode 100644 index 0000000..aba61c2 --- /dev/null +++ b/src/translate/grt/grt-vcdz.ads @@ -0,0 +1,28 @@ +-- GHDL Run Time (GRT) - VCD .gz module. +-- Copyright (C) 2005 - 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. + +package Grt.Vcdz is + procedure Register; +end Grt.Vcdz; diff --git a/src/translate/grt/grt-vital_annotate.adb b/src/translate/grt/grt-vital_annotate.adb new file mode 100644 index 0000000..93ecb81 --- /dev/null +++ b/src/translate/grt/grt-vital_annotate.adb @@ -0,0 +1,688 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- 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.Types; use Grt.Types; +with Grt.Hooks; use Grt.Hooks; +with Grt.Astdio; use Grt.Astdio; +with Grt.Stdio; use Grt.Stdio; +with Grt.Options; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Errors; use Grt.Errors; + +package body Grt.Vital_Annotate is + -- Point of the annotation. + Sdf_Top : VhpiHandleT; + + -- Instance being annotated. + Sdf_Inst : VhpiHandleT; + + Flag_Dump : Boolean := False; + Flag_Verbose : constant Boolean := False; + + function Name_Compare (Handle : VhpiHandleT; + Name : String; + Property : VhpiStrPropertyT := VhpiNameP) + return Boolean + is + Obj_Name : String (1 .. Name'Length); + Len : Natural; + begin + Vhpi_Get_Str (Property, Handle, Obj_Name, Len); + if Len = Name'Length and then Obj_Name = Name then + return True; + else + return False; + end if; + end Name_Compare; + + -- Note: RES may alias CUR. + procedure Find_Instance (Cur : VhpiHandleT; + Res : out VhpiHandleT; + Name : String; + Ok : out Boolean) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + begin + Ok := False; + Vhpi_Iterator (VhpiInternalRegions, Cur, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + loop + Vhpi_Scan (It, Res, Error); + exit when Error /= AvhpiErrorOk; + if Name_Compare (Res, Name) then + Ok := True; + return; + end if; + end loop; + return; +-- Put ("find instance: "); +-- Put (Name); +-- New_Line; + end Find_Instance; + + procedure Find_Generic (Gen_Name : String; + Gen_Handle : out VhpiHandleT; + Port1_Name : String; + Port1_Handle : out VhpiHandleT; + Port2_Name : String; + Port2_Handle : out VhpiHandleT) + is + Error : AvhpiErrorT; + It : VhpiHandleT; + Decl : VhpiHandleT; + begin + Gen_Handle := Null_Handle; + Port1_Handle := Null_Handle; + Port2_Handle := Null_Handle; + + Vhpi_Iterator (VhpiDecls, Sdf_Inst, It, Error); + if Error /= AvhpiErrorOk then + return; + end if; + + -- Look for the generic. + loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK; + if Name_Compare (Decl, Gen_Name) then + Gen_Handle := Decl; + exit; + end if; + end loop; + + -- Skip generics. + while Vhpi_Get_Kind (Decl) = VhpiGenericDeclK loop + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + -- Look for ports. + loop + exit when Vhpi_Get_Kind (Decl) /= VhpiPortDeclK; + if Name_Compare (Decl, Port1_Name) then + Port1_Handle := Decl; + exit when Port2_Name'Length = 0; + end if; + if Port2_Name'Length > 0 + and then Name_Compare (Decl, Port2_Name) + then + Port2_Handle := Decl; + exit when Vhpi_Get_Kind (Port1_Handle) /= VhpiUndefined; + end if; + Vhpi_Scan (It, Decl, Error); + if Error /= AvhpiErrorOk then + return; + end if; + end loop; + + end Find_Generic; + + procedure Sdf_Header (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + case Context.Version is + when Sdf_2_1 => + Put ("found SDF file version 2.1"); + when Sdf_Version_Unknown => + Put ("found SDF file without version"); + when Sdf_Version_Bad => + Put ("found SDF file with unknown version"); + end case; + New_Line; + end if; + end Sdf_Header; + + procedure Sdf_Celltype (Context : Sdf_Context_Type) + is + begin + if Flag_Dump then + Put ("celltype: "); + Put (Context.Celltype (1 .. Context.Celltype_Len)); + New_Line; + Put ("instance:"); + return; + end if; + Sdf_Inst := Sdf_Top; + end Sdf_Celltype; + + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean) + is + pragma Unreferenced (Context); + begin + if Flag_Dump then + Put (' '); + Put (Instance); + Status := True; + return; + end if; + + Find_Instance (Sdf_Inst, Sdf_Inst, Instance, Status); + end Sdf_Instance; + + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean) + is + begin + if Flag_Dump then + Status := True; + New_Line; + return; + end if; + case Vhpi_Get_Kind (Sdf_Inst) is + when VhpiRootInstK => + declare + Hdl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Status := False; + Vhpi_Handle (VhpiDesignUnit, Sdf_Inst, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiDesignUnit"); + return; + end if; + case Vhpi_Get_Kind (Hdl) is + when VhpiArchBodyK => + Vhpi_Handle (VhpiPrimaryUnit, Hdl, Hdl, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("VhpiPrimaryUnit"); + return; + end if; + when others => + Internal_Error ("sdf_instance_end"); + end case; + Status := Name_Compare + (Hdl, Context.Celltype (1 .. Context.Celltype_Len)); + end; + when VhpiCompInstStmtK => + Status := Name_Compare + (Sdf_Inst, + Context.Celltype (1 .. Context.Celltype_Len), + VhpiCompNameP); + when others => + Status := False; + end case; + end Sdf_Instance_End; + + VitalDelayType01 : VhpiHandleT; + VitalDelayType01Z : VhpiHandleT; + VitalDelayType01ZX : VhpiHandleT; + VitalDelayArrayType01 : VhpiHandleT; + VitalDelayType : VhpiHandleT; + VitalDelayArrayType : VhpiHandleT; + + type Map_Type is array (1 .. 12) of Natural; + Map_1 : constant Map_Type := (1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0); + Map_2 : constant Map_Type := (1, 2, 1, 1, 2, 2, 0, 0, 0, 0, 0, 0); + Map_3 : constant Map_Type := (1, 2, 3, 1, 3, 2, 0, 0, 0, 0, 0, 0); + Map_6 : constant Map_Type := (1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0); + --Map_12 : constant Map_Type := (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12); + + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT; + Nbr : Natural; + Map : Map_Type) + return Boolean + is + It : VhpiHandleT; + El : VhpiHandleT; + Error : AvhpiErrorT; + N : Natural; + begin + Vhpi_Iterator (VhpiIndexedNames, Gen, It, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames"); + return False; + end if; + for I in 1 .. Nbr loop + Vhpi_Scan (It, El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("scan on vhpiIndexedNames"); + return False; + end if; + N := Map (I); + if Context.Timing_Set (N) then + if Vhpi_Put_Value (El, Context.Timing (N) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value"); + return False; + end if; + end if; + end loop; + return True; + end Write_Td_Delay_Generic; + + function Write_Td_Delay_Generic (Context : Sdf_Context_Type; + Gen : VhpiHandleT) + return Boolean + is + Gen_Basetype : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("write_td_delay_generic: vhpiBaseType"); + return False; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 2, Map_2); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) then + case Context.Timing_Nbr is + when 1 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_1); + when 2 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_2); + when 3 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_3); + when 6 => + return Write_Td_Delay_Generic (Context, Gen, 6, Map_6); + when others => + Errors.Error + ("timing generic type mismatch SDF timing specification"); + end case; + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType) then + if Vhpi_Put_Value (Gen, Context.Timing (1) * 1000) /= AvhpiErrorOk + then + Internal_Error ("vhpi_put_value (vitaldelaytype)"); + else + return True; + end if; + else + Internal_Error ("write_td_delay_generic: unhandled generic type"); + end if; + end Write_Td_Delay_Generic; + + procedure Generic_Get_Bounds (Port : VhpiHandleT; + Left : out Ghdl_I32; + Len : out Ghdl_Index_Type; + Up : out Boolean) + is + Port_Type, Port_Range : VhpiHandleT; + Error : AvhpiErrorT; + Right : VhpiIntT; + begin + Vhpi_Handle (VhpiSubtype, Port, Port_Type, Error); + Left := 0; + Len := 0; + Up := True; + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiSubtype - port"); + return; + end if; + Vhpi_Handle_By_Index (VhpiConstraints, Port_Type, 1, Port_Range, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexConstraints - port"); + return; + end if; + Vhpi_Get (VhpiLeftBoundP, Port_Range, Left, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiLeftBoundP - port"); + return; + end if; + Vhpi_Get (VhpiRightBoundP, Port_Range, Right, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiRightBoundP - port"); + return; + end if; + Vhpi_Get (VhpiIsUpP, Port_Range, Up, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIsUpP - port"); + return; + end if; + if Up then + Len := Ghdl_Index_Type (Right - Left) + 1; + else + Len := Ghdl_Index_Type (Left - Right) + 1; + end if; + end Generic_Get_Bounds; + + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean) + is + Gen : VhpiHandleT; + Gen_Basetype : VhpiHandleT; + Port1, Port2 : VhpiHandleT; + Error : AvhpiErrorT; + begin + if Flag_Dump then + Put ("generic: "); + Put (Name); + if Context.Timing_Nbr = 0 then + Put (' '); + Put_I64 (stdout, Context.Timing (1)); + else + for I in 1 .. 12 loop + Put (' '); + if Context.Timing_Set (I) then + Put_I64 (stdout, Context.Timing (I)); + else + Put ('?'); + end if; + end loop; + end if; + + New_Line; + Ok := True; + return; + end if; + + Ok := False; + + if Context.Port_Num = 1 then + Context.Ports (2).Name_Len := 0; + end if; + Find_Generic + (Name, Gen, + Context.Ports (1).Name (1 .. Context.Ports (1).Name_Len), Port1, + Context.Ports (2).Name (1 .. Context.Ports (2).Name_Len), Port2); + if Vhpi_Get_Kind (Gen) = VhpiUndefined + or else Vhpi_Get_Kind (Port1) = VhpiUndefined + or else (Context.Port_Num = 2 + and then Vhpi_Get_Kind (Port2) = VhpiUndefined) + then + return; + end if; + + -- Extract subtype. + Vhpi_Handle (VhpiBaseType, Gen, Gen_Basetype, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiBaseType"); + return; + end if; + if Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01Z) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayType01ZX) + then + Ok := Write_Td_Delay_Generic (Context, Gen); + elsif Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType01) + or else Vhpi_Compare_Handles (Gen_Basetype, VitalDelayArrayType) + then + declare + Left_Gen, Left1, Left2 : Ghdl_I32; + Len_Gen, Len1, Len2 : Ghdl_Index_Type; + Up_Gen, Up1, Up2 : Boolean; + Pos : Ghdl_Index_Type; + Gen_El : VhpiHandleT; + begin + Generic_Get_Bounds (Gen, Left_Gen, Len_Gen, Up_Gen); + if Context.Port_Num >= 1 + and then Context.Ports (1).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port1, Left1, Len1, Up1); + if Up1 then + Pos := Ghdl_Index_Type (Context.Ports (1).L - Left1); + else + Pos := Ghdl_Index_Type (Left1 - Context.Ports (1).L); + end if; + else + Pos := 0; + end if; + if Context.Port_Num >= 2 + and then Context.Ports (2).L /= Invalid_Dnumber + then + Generic_Get_Bounds (Port2, Left2, Len2, Up2); + Pos := Pos * Len2; + if Up2 then + Pos := Pos + Ghdl_Index_Type (Context.Ports (2).L - Left2); + else + Pos := Pos + Ghdl_Index_Type (Left2 - Context.Ports (2).L); + end if; + end if; + Vhpi_Handle_By_Index + (VhpiIndexedNames, Gen, Integer (Pos), Gen_El, Error); + if Error /= AvhpiErrorOk then + Internal_Error ("vhpiIndexedNames - gen_el"); + return; + end if; + Ok := Write_Td_Delay_Generic (Context, Gen_El); + end; + else + Errors.Error_C ("vital: unhandled generic type for generic "); + Errors.Error_E (Name); + end if; + end Sdf_Generic; + + + procedure Annotate (Arg : String) + is + S, E : Natural; + Ok : Boolean; + begin + if Flag_Verbose then + Put ("sdf annotate: "); + Put (Arg); + New_Line; + end if; + + -- Find scope by name. + Get_Root_Inst (Sdf_Top); + E := Arg'First; + S := E; + L1: loop + -- Skip path separator. + while Arg (E) = '/' or Arg (E) = '.' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + exit L1 when E > Arg'Last or else Arg (E) = '='; + + -- Instance element. + S := E; + while Arg (E) /= '=' and Arg (E) /= '.' and Arg (E) /= '/' loop + E := E + 1; + exit L1 when E > Arg'Last; + end loop; + + -- Path element. + if E - 1 >= S then + Find_Instance (Sdf_Top, Sdf_Top, Arg (S .. E - 1), Ok); + if not Ok then + Error_C ("cannot find instance '"); + Error_C (Arg (S .. E - 1)); + Error_E ("' for sdf annotation"); + return; + end if; + end if; + end loop L1; + + -- start annotation. + if E >= Arg'Last or else Arg (E) /= '=' then + Error_C ("no filename in sdf option '"); + Error_C (Arg); + Error_E ("'"); + return; + end if; + if not Sdf.Parse_Sdf_File (Arg (E + 1 .. Arg'Last)) then + null; + end if; + end Annotate; + + procedure Extract_Vital_Delay_Type + is + It : VhpiHandleT; + Pkg : VhpiHandleT; + Decl : VhpiHandleT; + Basetype : VhpiHandleT; + Status : AvhpiErrorT; + begin + Get_Package_Inst (It); + loop + Vhpi_Scan (It, Pkg, Status); + exit when Status /= AvhpiErrorOk; + exit when Name_Compare (Pkg, "vital_timing") + and then Name_Compare (Pkg, "ieee", VhpiLibLogicalNameP); + end loop; + if Status /= AvhpiErrorOk then + Error ("package ieee.vital_timing not found, SDF annotation aborted"); + return; + end if; + Vhpi_Iterator (VhpiDecls, Pkg, It, Status); + if Status /= AvhpiErrorOk then + Error ("cannot iterate on vital_timing"); + return; + end if; + loop + Vhpi_Scan (It, Decl, Status); + exit when Status /= AvhpiErrorOk; + if Vhpi_Get_Kind (Decl) = VhpiSubtypeDeclK + or else Vhpi_Get_Kind (Decl) = VhpiArrayTypeDeclK + then + Vhpi_Handle (VhpiBaseType, Decl, Basetype, Status); + if Status = AvhpiErrorOk then + if Name_Compare (Decl, "vitaldelaytype01") then + VitalDelayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01z") then + VitalDelayType01Z := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype01zx") then + VitalDelayType01ZX := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype01") then + VitalDelayArrayType01 := Basetype; + elsif Name_Compare (Decl, "vitaldelaytype") then + VitalDelayType := Basetype; + elsif Name_Compare (Decl, "vitaldelayarraytype") then + VitalDelayArrayType := Basetype; + end if; + end if; + end if; + end loop; + if Vhpi_Get_Kind (VitalDelayType01) = VhpiUndefined then + Error ("cannot find VitalDelayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType01Z) = VhpiUndefined then + Error ("cannot find VitalDelayType01Z in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType01ZX) = VhpiUndefined then + Error ("cannot find VitalDelayType01ZX in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayArrayType01) = VhpiUndefined then + Error ("cannot find VitalDelayArrayType01 in ieee.vital_timing"); + return; + end if; + if Vhpi_Get_Kind (VitalDelayType) = VhpiUndefined then + Error ("cannot find VitalDelayType in ieee.vital_timing"); + return; + end if; + end Extract_Vital_Delay_Type; + + Has_Sdf_Option : Boolean := False; + + procedure Sdf_Start + is + use Grt.Options; + Len : Integer; + Beg : Integer; + Arg : Ghdl_C_String; + begin + if not Has_Sdf_Option then + -- Nothing to do. + return; + end if; + Flag_Dump := False; + + -- Extract VitalDelayType(s) from VITAL_Timing package. + Extract_Vital_Delay_Type; + + -- Annotate. + for I in 1 .. Last_Opt loop + Arg := Argv (I); + Len := strlen (Arg); + if Len > 5 and then Arg (1 .. 6) = "--sdf=" then + Sdf_Mtm := Typical; + Beg := 7; + if Len > 10 then + if Arg (7 .. 10) = "typ=" then + Beg := 11; + elsif Arg (7 .. 10) = "min=" then + Sdf_Mtm := Minimum; + Beg := 11; + elsif Arg (7 .. 10) = "max=" then + Sdf_Mtm := Maximum; + Beg := 11; + end if; + end if; + Annotate (Arg (Beg .. Len)); + end if; + end loop; + end Sdf_Start; + + function Sdf_Option (Option : String) return Boolean + is + Opt : constant String (1 .. Option'Length) := Option; + begin + if Opt'Length > 11 and then Opt (1 .. 11) = "--sdf-dump=" then + Flag_Dump := True; + if Sdf.Parse_Sdf_File (Opt (12 .. Opt'Last)) then + null; + end if; + return True; + end if; + if Opt'Length > 5 and then Opt (1 .. 6) = "--sdf=" then + Has_Sdf_Option := True; + return True; + else + return False; + end if; + end Sdf_Option; + + procedure Sdf_Help is + begin + Put_Line (" --sdf=[min=|typ=|max=]TOP=FILENAME"); + Put_Line (" annotate TOP with SDF delay file FILENAME"); + end Sdf_Help; + + Sdf_Hooks : aliased constant Hooks_Type := + (Option => Sdf_Option'Access, + Help => Sdf_Help'Access, + Init => Proc_Hook_Nil'Access, + Start => Sdf_Start'Access, + Finish => Proc_Hook_Nil'Access); + + procedure Register is + begin + Register_Hooks (Sdf_Hooks'Access); + end Register; +end Grt.Vital_Annotate; diff --git a/src/translate/grt/grt-vital_annotate.ads b/src/translate/grt/grt-vital_annotate.ads new file mode 100644 index 0000000..acf82bb --- /dev/null +++ b/src/translate/grt/grt-vital_annotate.ads @@ -0,0 +1,42 @@ +-- GHDL Run Time (GRT) - VITAL annotator. +-- 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.Sdf; use Grt.Sdf; + +package Grt.Vital_Annotate is + pragma Elaborate_Body (Grt.Vital_Annotate); + + procedure Sdf_Header (Context : Sdf_Context_Type); + procedure Sdf_Celltype (Context : Sdf_Context_Type); + procedure Sdf_Instance (Context : in out Sdf_Context_Type; + Instance : String; + Status : out Boolean); + procedure Sdf_Instance_End (Context : Sdf_Context_Type; + Status : out Boolean); + procedure Sdf_Generic (Context : in out Sdf_Context_Type; + Name : String; + Ok : out Boolean); + + procedure Register; +end Grt.Vital_Annotate; diff --git a/src/translate/grt/grt-vpi.adb b/src/translate/grt/grt-vpi.adb new file mode 100644 index 0000000..9b77319 --- /dev/null +++ b/src/translate/grt/grt-vpi.adb @@ -0,0 +1,988 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- 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. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +------------------------------------------------------------------------------- +-- TODO: +------------------------------------------------------------------------------- +-- DONE: +-- * The GHDL VPI implementation doesn't support time +-- callbacks (cbReadOnlySynch). This is needed to support +-- IVI run. Currently, the GHDL simulation runs until +-- complete once a single 'run' is performed... +-- * You are loading '_'-prefixed symbols when you +-- load the vpi plugin. On Linux, there is no leading +-- '_'. I just added code to try both '_'-prefixed and +-- non-'_'-prefixed symbols. I have placed the changed +-- file in the same download dir as the snapshot +-- * I did find out why restart doesn't work for GHDL. +-- You are passing back the leaf name of signals when the +-- FullName is requested. +------------------------------------------------------------------------------- + +with Ada.Unchecked_Deallocation; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Signals; use Grt.Signals; +with Grt.Table; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Vcd; use Grt.Vcd; +with Grt.Errors; use Grt.Errors; +with Grt.Rtis_Types; +pragma Elaborate_All (Grt.Table); + +package body Grt.Vpi is + -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. + -- This is now set in Makefile, since this is target dependent. + -- pragma Linker_Options ("-ldl"); + + --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; + --errNoString: constant String := "grt-vcd.adb: no string" & NUL; + + type Vpi_Index_Type is new Integer; + +------------------------------------------------------------------------------- +-- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- debugging helpers + procedure dbgPut (Str : String) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Str'Address, Str'Length, 1, stderr); + end dbgPut; + + procedure dbgPut (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), stderr); + end dbgPut; + + procedure dbgNew_Line is + begin + dbgPut (Nl); + end dbgNew_Line; + + procedure dbgPut_Line (Str : String) + is + begin + dbgPut (Str); + dbgNew_Line; + end dbgPut_Line; + +-- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type) +-- is +-- begin +-- Put_Str_Len(stderr, Str); +-- dbgNew_Line; +-- end dbgPut_Line; + + procedure Free is new Ada.Unchecked_Deallocation + (Name => vpiHandle, Object => struct_vpiHandle); + + ------------------------------------------------------------------------ + -- NUL-terminate strings. + -- note: there are several buffers + -- see IEEE 1364-2001 +-- tmpstring1: string(1..1024); +-- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String +-- is +-- begin +-- for i in 1..Str.Len loop +-- tmpstring1(i):= Str.Str(i); +-- end loop; +-- tmpstring1(Str.Len+1):= NUL; +-- return To_Ghdl_C_String (tmpstring1'Address); +-- end NulTerminate1; + +------------------------------------------------------------------------------- +-- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + ------------------------------------------------------------------------ + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + -- Obtain an iterator handle to objects with a one-to-many relationship. + -- see IEEE 1364-2001, page 685 + function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle + is + Res : vpiHandle; + Rel : VhpiOneToManyT; + Error : AvhpiErrorT; + begin + --dbgPut_Line ("vpi_iterate"); + + case aType is + when vpiNet => + Rel := VhpiDecls; + when vpiModule => + if Ref = null then + Res := new struct_vpiHandle (vpiModule); + Get_Root_Inst (Res.Ref); + return Res; + else + Rel := VhpiInternalRegions; + end if; + when vpiInternalScope => + Rel := VhpiInternalRegions; + when others => + return null; + end case; + + -- find the proper start object for our scan + if Ref = null then + return null; + end if; + + Res := new struct_vpiHandle (aType); + Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error); + + if Error /= AvhpiErrorOk then + Free (Res); + end if; + return Res; + end vpi_iterate; + + ------------------------------------------------------------------------ + -- int vpi_get(int property, vpiHandle ref) + -- Get the value of an integer or boolean property of an object. + -- see IEEE 1364-2001, chapter 27.6, page 667 +-- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer +-- is +-- begin +-- case aRef.Kind is +-- when Ghdl_Name_Entity +-- | Ghdl_Name_Architecture +-- | Ghdl_Name_Block +-- | Ghdl_Name_Generate_Iterative +-- | Ghdl_Name_Generate_Conditional +-- | Ghdl_Name_Instance => +-- return vpiModule; +-- when Ghdl_Name_Signal => +-- return vpiNet; +-- when others => +-- return vpiUndefined; +-- end case; +-- end ii_vpi_get_type; + + function vpi_get (Property: integer; Ref: vpiHandle) return Integer + is + begin + case Property is + when vpiType=> + return Ref.mType; + when vpiTimePrecision=> + return -9; -- is this nano-seconds? + when others=> + dbgPut_Line ("vpi_get: unknown property"); + return 0; + end case; + end vpi_get; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_scan(vpiHandle iter) + -- Scan the Verilog HDL hierarchy for objects with a one-to-many + -- relationship. + -- see IEEE 1364-2001, chapter 27.36, page 709 + function vpi_scan (Iter: vpiHandle) return vpiHandle + is + Res : VhpiHandleT; + Error : AvhpiErrorT; + R : vpiHandle; + begin + --dbgPut_Line ("vpi_scan"); + if Iter = null then + return null; + end if; + + -- There is only one top-level module. + if Iter.mType = vpiModule then + case Vhpi_Get_Kind (Iter.Ref) is + when VhpiRootInstK => + R := new struct_vpiHandle (Iter.mType); + R.Ref := Iter.Ref; + Iter.Ref := Null_Handle; + return R; + when VhpiUndefined => + return null; + when others => + -- Fall through. + null; + end case; + end if; + + loop + Vhpi_Scan (Iter.Ref, Res, Error); + exit when Error /= AvhpiErrorOk; + + case Vhpi_Get_Kind (Res) is + when VhpiEntityDeclK + | VhpiArchBodyK + | VhpiBlockStmtK + | VhpiIfGenerateK + | VhpiForGenerateK + | VhpiCompInstStmtK => + case Iter.mType is + when vpiInternalScope + | vpiModule => + return new struct_vpiHandle'(mType => vpiModule, + Ref => Res); + when others => + null; + end case; + when VhpiPortDeclK + | VhpiSigDeclK => + if Iter.mType = vpiNet then + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Res, Info); + if Info.Kind /= Vcd_Bad then + return new struct_vpiHandle'(mType => vpiNet, + Ref => Res); + end if; + end; + end if; + when others => + null; + end case; + end loop; + return null; + end vpi_scan; + + ------------------------------------------------------------------------ + -- char *vpi_get_str(int property, vpiHandle ref) + -- see IEEE 1364-2001, page xxx + Tmpstring2 : String (1 .. 1024); + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String + is + Prop : VhpiStrPropertyT; + Len : Natural; + begin + --dbgPut_Line ("vpiGetStr"); + + if Ref = null then + return null; + end if; + + case Property is + when vpiFullName=> + Prop := VhpiFullNameP; + when vpiName=> + Prop := VhpiNameP; + when others=> + dbgPut_Line ("vpi_get_str: undefined property"); + return null; + end case; + Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len); + Tmpstring2 (Len + 1) := NUL; + if Property = vpiFullName then + for I in Tmpstring2'First .. Len loop + if Tmpstring2 (I) = ':' then + Tmpstring2 (I) := '.'; + end if; + end loop; + -- Remove the initial '.'. + return To_Ghdl_C_String (Tmpstring2 (2)'Address); + else + return To_Ghdl_C_String (Tmpstring2'Address); + end if; + end vpi_get_str; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_handle(int type, vpiHandle ref) + -- Obtain a handle to an object with a one-to-one relationship. + -- see IEEE 1364-2001, chapter 27.16, page 682 + function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle + is + Res : vpiHandle; + begin + --dbgPut_Line ("vpi_handle"); + + if Ref = null then + return null; + end if; + + case aType is + when vpiScope => + case Ref.mType is + when vpiModule => + Res := new struct_vpiHandle (vpiScope); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when vpiRightRange + | vpiLeftRange => + case Ref.mType is + when vpiNet => + Res := new struct_vpiHandle (aType); + Res.Ref := Ref.Ref; + return Res; + when others => + return null; + end case; + when others => + return null; + end case; + end vpi_handle; + + ------------------------------------------------------------------------ + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + -- Retrieve the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + Tmpstring3idx : integer; + Tmpstring3 : String (1 .. 1024); + procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1) + is + begin + case Val is + when True => + Tmpstring3 (Tmpstring3idx) := '1'; + when False => + Tmpstring3 (Tmpstring3idx) := '0'; + end case; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_B1; + + procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8) + is + type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character; + Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-"; + begin + if Val not in Map_Type_E8'range then + Tmpstring3 (Tmpstring3idx) := '?'; + else + Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val); + end if; + Tmpstring3idx := Tmpstring3idx + 1; + end ii_vpi_get_value_bin_str_E8; + + function ii_vpi_get_value_bin_str (Obj : VhpiHandleT) + return Ghdl_C_String + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + case Vhpi_Get_Kind (Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return null; + end case; + + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return null; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + Tmpstring3idx := 1; -- reset string buffer + + case Info.Val is + when Vcd_Effective => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Value.E8); + end loop; + end case; + when Vcd_Driving => + case Info.Kind is + when Vcd_Bad + | Vcd_Integer32 + | Vcd_Float64 => + return null; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_B1 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.B1); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_get_value_bin_str_E8 + (To_Signal_Arr_Ptr (Info.Addr)(J).Driving_Value.E8); + end loop; + end case; + end case; + Tmpstring3 (Tmpstring3idx) := NUL; + return To_Ghdl_C_String (Tmpstring3'Address); + end ii_vpi_get_value_bin_str; + + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) + is + begin + case Value.Format is + when vpiObjTypeVal=> + -- fill in the object type and value: + -- For an integer, vpiIntVal + -- For a real, vpiRealVal + -- For a scalar, either vpiScalar or vpiStrength + -- For a time variable, vpiTimeVal with vpiSimTime + -- For a vector, vpiVectorVal + dbgPut_Line ("vpi_get_value: vpiObjTypeVal"); + when vpiBinStrVal=> + Value.Str := ii_vpi_get_value_bin_str (Expr.Ref); + --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all); + when vpiOctStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal=> + dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal"); + when vpiIntVal=> + case Expr.mType is + when vpiLeftRange + | vpiRightRange=> + declare + Info : Verilog_Wire_Info; + begin + Get_Verilog_Wire (Expr.Ref, Info); + if Info.Irange /= null then + if Expr.mType = vpiLeftRange then + Value.Integer_m := Integer (Info.Irange.I32.Left); + else + Value.Integer_m := Integer (Info.Irange.I32.Right); + end if; + else + Value.Integer_m := 0; + end if; + end; + when others=> + dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType"); + end case; + when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal"); + when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal"); + when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal"); + when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal"); + when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal"); + when others=> dbgPut_Line("vpi_get_value: unknown mFormat"); + end case; + end vpi_get_value; + + ------------------------------------------------------------------------ + -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + -- Alter the simulation value of an object. + -- see IEEE 1364-2001, chapter 27.14, page 675 + -- FIXME + + procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + -- use the Set_Effective_Value procedure to update the signal + case Value is + when '0' => + Tempval.B1 := false; + when '1' => + Tempval.B1 := true; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B1: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_B1; + + procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr; + Value : Character) + is + Tempval : Value_Union; + begin + case Value is + when 'U' => + Tempval.E8 := 0; + when 'X' => + Tempval.E8 := 1; + when '0' => + Tempval.E8 := 2; + when '1' => + Tempval.E8 := 3; + when 'Z' => + Tempval.E8 := 4; + when 'W' => + Tempval.E8 := 5; + when 'L' => + Tempval.E8 := 6; + when 'H' => + Tempval.E8 := 7; + when '-' => + Tempval.E8 := 8; + when others => + dbgPut_Line("ii_vpi_put_value_bin_str_B8: " + & "wrong character - signal wont be set"); + return; + end case; + SigPtr.Driving_Value := Tempval; + Set_Effective_Value (SigPtr, Tempval); + end ii_vpi_put_value_bin_str_E8; + + + procedure ii_vpi_put_value_bin_str(Obj : VhpiHandleT; + ValueStr : Ghdl_C_String) + is + Info : Verilog_Wire_Info; + Len : Ghdl_Index_Type; + begin + -- Check the Obj type. + -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT + -- when it doesnt come from a callback. + case Vhpi_Get_Kind(Obj) is + when VhpiPortDeclK + | VhpiSigDeclK => + null; + when others => + return; + end case; + + -- The following code segment was copied from the + -- ii_vpi_get_value function. + -- Get verilog compat info. + Get_Verilog_Wire (Obj, Info); + if Info.Kind = Vcd_Bad then + return; + end if; + + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + -- Step 1: convert vpi object to internal format. + -- p_vpi_handle -> Ghdl_Signal_Ptr + -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic + + -- Step 2: convert datum to appropriate type. + -- Ghdl_C_String -> Value_Union + + -- Step 3: assigns value to object using Set_Effective_Value + -- call (from grt-signals) + -- Set_Effective_Value(sig_ptr, conv_value); + + + -- Took the skeleton from ii_vpi_get_value function + -- This point of the function must convert the string value to the + -- native ghdl format. + case Info.Kind is + when Vcd_Bad => + return; + when Vcd_Bit + | Vcd_Bool + | Vcd_Bitvector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_B1( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Stdlogic + | Vcd_Stdlogic_Vector => + for J in 0 .. Len - 1 loop + ii_vpi_put_value_bin_str_E8( + To_Signal_Arr_Ptr(Info.Addr)(J), ValueStr(Integer(J+1))); + end loop; + when Vcd_Integer32 + | Vcd_Float64 => + null; + end case; + + -- Always return null, because this simulation kernel cannot send + -- a handle to the event back. + return; + end ii_vpi_put_value_bin_str; + + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj: vpiHandle; + aValue: p_vpi_value; + aWhen: p_vpi_time; + aFlags: integer) + return vpiHandle + is + pragma Unreferenced (aWhen); + pragma Unreferenced (aFlags); + begin + -- A very simple write procedure for VPI. + -- Basically, it accepts bin_str values and converts to appropriate + -- types (only std_logic and bit values and vectors). + + -- It'll use Set_Effective_Value procedure to update signals + + -- Ignoring aWhen and aFlags, for now. + + -- Checks the format of aValue. Only vpiBinStrVal will be accepted + -- for now. + case aValue.Format is + when vpiObjTypeVal => + dbgPut_Line ("vpi_put_value: vpiObjTypeVal"); + when vpiBinStrVal => + ii_vpi_put_value_bin_str(aObj.Ref, aValue.Str); + -- dbgPut_Line ("vpi_put_value: vpiBinStrVal"); + when vpiOctStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal"); + when vpiDecStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal"); + when vpiHexStrVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal"); + when vpiScalarVal => + dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); + when vpiIntVal => + dbgPut_Line ("vpi_put_value: vpiIntVal"); + when vpiRealVal => + dbgPut_Line("vpi_put_value: vpiRealVal"); + when vpiStringVal => + dbgPut_Line("vpi_put_value: vpiStringVal"); + when vpiTimeVal => + dbgPut_Line("vpi_put_value: vpiTimeVal"); + when vpiVectorVal => + dbgPut_Line("vpi_put_value: vpiVectorVal"); + when vpiStrengthVal => + dbgPut_Line("vpi_put_value: vpiStrengthVal"); + when others => + dbgPut_Line("vpi_put_value: unknown mFormat"); + end case; + + -- Must return a scheduled event caused by vpi_put_value() + -- Still dont know how to do it. + return null; + end vpi_put_value; + + ------------------------------------------------------------------------ + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + -- see IEEE 1364-2001, page xxx + Sim_Time : Std_Time; + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) + is + pragma Unreferenced (Obj); + begin + --dbgPut_Line ("vpi_get_time"); + Time.mType := vpiSimTime; + Time.mHigh := 0; + Time.mLow := Integer (Sim_Time / 1000000); + Time.mReal := 0.0; + end vpi_get_time; + + ------------------------------------------------------------------------ + -- vpiHandle vpi_register_cb(p_cb_data data) + g_cbEndOfCompile : p_cb_data; + g_cbEndOfSimulation: p_cb_data; + --g_cbValueChange: s_cb_data; + g_cbReadOnlySync: p_cb_data; + + type Vpi_Var_Type is record + Info : Verilog_Wire_Info; + Cb : s_cb_data; + end record; + + package Vpi_Table is new Grt.Table + (Table_Component_Type => Vpi_Var_Type, + Table_Index_Type => Vpi_Index_Type, + Table_Low_Bound => 0, + Table_Initial => 32); + + function vpi_register_cb (Data : p_cb_data) return vpiHandle + is + Res : p_cb_data := null; + begin + --dbgPut_Line ("vpi_register_cb"); + case Data.Reason is + when cbEndOfCompile => + Res := new s_cb_data'(Data.all); + g_cbEndOfCompile := Res; + Sim_Time:= 0; + when cbEndOfSimulation => + Res := new s_cb_data'(Data.all); + g_cbEndOfSimulation := Res; + when cbValueChange => + declare + N : Vpi_Index_Type; + begin + --g_cbValueChange:= aData.all; + Vpi_Table.Increment_Last; + N := Vpi_Table.Last; + Vpi_Table.Table (N).Cb := Data.all; + Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info); + end; + when cbReadOnlySynch=> + Res := new s_cb_data'(Data.all); + g_cbReadOnlySync := Res; + when others=> + dbgPut_Line ("vpi_register_cb: unknwon reason"); + end case; + if Res /= null then + return new struct_vpiHandle'(mType => vpiCallback, + Cb => Res); + else + return null; + end if; + end vpi_register_cb; + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object (aRef: vpiHandle) return integer + is + pragma Unreferenced (aRef); + begin + return 0; + end vpi_free_object; + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer + is + pragma Unreferenced (aVlog_info_p); + begin + return 0; + end vpi_get_vlog_info; + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle + is + pragma Unreferenced (aRef); + pragma Unreferenced (aIndex); + begin + return null; + end vpi_handle_by_index; + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_close; + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd: integer) return integer + is + pragma Unreferenced (Mcd); + begin + return 0; + end vpi_mcd_name; + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer + is + pragma Unreferenced (Name); + begin + return 0; + end vpi_mcd_open; + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf(aSs: System.Address) + is + pragma Unreferenced (aSs); + begin + null; + end vpi_register_systf; + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return Integer + is + pragma Unreferenced (Ref); + begin + return 0; + end vpi_remove_cb; + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt : Address; Ap : Address) + is + pragma Unreferenced (Fmt); + pragma Unreferenced (Ap); + begin + null; + end vpi_vprintf; + + -- missing here, see grt-cvpi.c: + -- vpi_mcd_open_x + -- vpi_mcd_vprintf + -- vpi_mcd_fputc + -- vpi_mcd_fgetc + -- vpi_sim_vcontrol + -- vpi_chk_error + -- pi_handle_by_name + +------------------------------------------------------------------------------ +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------ + + -- VCD filename. + Vpi_Filename : String_Access := null; + + ------------------------------------------------------------------------ + -- Return TRUE if OPT is an option for VPI. + function Vpi_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 5) = '=' then + -- Add an extra NUL character. + Vpi_Filename := new String (1 .. Opt'Length - 6 + 1); + Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); + Vpi_Filename (Vpi_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Vpi_Option; + + ------------------------------------------------------------------------ + procedure Vpi_Help is + begin + Put_Line (" --vpi=FILENAME load VPI module"); + end Vpi_Help; + + ------------------------------------------------------------------------ + -- Called before elaboration. + + -- void loadVpiModule(const char* modulename) + function LoadVpiModule (Filename: Address) return Integer; + pragma Import (C, LoadVpiModule, "loadVpiModule"); + + + procedure Vpi_Init + is + begin + Sim_Time:= 0; + + --g_cbEndOfCompile.mCb_rtn:= null; + --g_cbEndOfSimulation.mCb_rtn:= null; + --g_cbValueChange.mCb_rtn:= null; + + if Vpi_Filename /= null then + if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then + Error ("cannot load VPI module"); + end if; + end if; + end Vpi_Init; + + procedure Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called after elaboration. + procedure Vpi_Start + is + Res : Integer; + pragma Unreferenced (Res); + begin + if Vpi_Filename = null then + return; + end if; + + Grt.Rtis_Types.Search_Types_RTI; + Register_Cycle_Hook (Vpi_Cycle'Access); + if g_cbEndOfCompile /= null then + Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile); + end if; + end Vpi_Start; + + ------------------------------------------------------------------------ + -- Called before each non delta cycle. + procedure Vpi_Cycle + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbReadOnlySync /= null + and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000) + then + Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync); + end if; + + for I in Vpi_Table.First .. Vpi_Table.Last loop + if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then + Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all + (To_p_cb_data (Vpi_Table.Table (I).Cb'Address)); + end if; + end loop; + + if Current_Time /= Std_Time'last then + Sim_Time:= Current_Time; + end if; + end Vpi_Cycle; + + ------------------------------------------------------------------------ + -- Called at the end of the simulation. + procedure Vpi_End + is + Res : Integer; + pragma Unreferenced (Res); + begin + if g_cbEndOfSimulation /= null then + Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation); + end if; + end Vpi_End; + + Vpi_Hooks : aliased constant Hooks_Type := + (Option => Vpi_Option'Access, + Help => Vpi_Help'Access, + Init => Vpi_Init'Access, + Start => Vpi_Start'Access, + Finish => Vpi_End'Access); + + procedure Register is + begin + Register_Hooks (Vpi_Hooks'Access); + end Register; +end Grt.Vpi; diff --git a/src/translate/grt/grt-vpi.ads b/src/translate/grt/grt-vpi.ads new file mode 100644 index 0000000..86fb073 --- /dev/null +++ b/src/translate/grt/grt-vpi.ads @@ -0,0 +1,252 @@ +-- GHDL Run Time (GRT) - VPI interface. +-- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram +-- +-- 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. + +-- Description: VPI interface for GRT runtime +-- the main purpose of this code is to interface with the +-- Icarus Verilog Interactive (IVI) simulator GUI + +with System; use System; +with Ada.Unchecked_Conversion; +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; + +package Grt.Vpi is + + -- properties, see vpi_user.h + vpiUndefined: constant integer := -1; + vpiType: constant integer := 1; + vpiName: constant integer := 2; + vpiFullName: constant integer := 3; + vpiTimePrecision: constant integer := 12; + + -- object codes, see vpi_user.h + vpiModule: constant integer := 32; + vpiNet: constant integer := 36; + vpiScope: constant integer := 84; + vpiInternalScope: constant integer := 92; + vpiLeftRange: constant integer := 79; + vpiRightRange: constant integer := 83; + + -- Additionnal constants. + vpiCallback : constant Integer := 200; + + -- codes for the format tag of the vpi_value structure + vpiBinStrVal: constant integer := 1; + vpiOctStrVal: constant integer := 2; + vpiDecStrVal: constant integer := 3; + vpiHexStrVal: constant integer := 4; + vpiScalarVal: constant integer := 5; + vpiIntVal: constant integer := 6; + vpiRealVal: constant integer := 7; + vpiStringVal: constant integer := 8; + vpiVectorVal: constant integer := 9; + vpiStrengthVal: constant integer := 10; + vpiTimeVal: constant integer := 11; + vpiObjTypeVal: constant integer := 12; + vpiSuppressVal: constant integer := 13; + + -- codes for type tag of vpi_time structure + vpiSimTime: constant integer := 2; + + -- codes for the reason tag of cb_data structure + cbValueChange: constant integer:= 1; + cbReadOnlySynch: constant integer:= 7; + cbEndOfCompile: constant integer:= 10; + cbEndOfSimulation:constant integer:= 12; + + type struct_vpiHandle (mType : Integer := vpiUndefined); + type vpiHandle is access struct_vpiHandle; + + -- typedef struct t_vpi_time { + -- int type; + -- unsigned int high; + -- unsigned int low; + -- double real; + -- } s_vpi_time, *p_vpi_time; + type s_vpi_time is record + mType : Integer; + mHigh : Integer; -- this should be unsigned + mLow : Integer; -- this should be unsigned + mReal : Float; -- this should be double + end record; + type p_vpi_time is access s_vpi_time; + + -- typedef struct t_vpi_value + -- { int format; + -- union + -- { char*str; + -- int scalar; + -- int integer; + -- double real; + -- struct t_vpi_time *time; + -- struct t_vpi_vecval *vector; + -- struct t_vpi_strengthval *strength; + -- char*misc; + -- } value; + -- } s_vpi_value, *p_vpi_value; + type s_vpi_value (Format : integer) is record + case Format is + when vpiBinStrVal + | vpiOctStrVal + | vpiDecStrVal + | vpiHexStrVal + | vpiStringVal => + Str : Ghdl_C_String; + when vpiScalarVal => + Scalar : Integer; + when vpiIntVal => + Integer_m : Integer; + --when vpiRealVal=> null; -- what is the equivalent to double? + --when vpiTimeVal=> mTime: p_vpi_time; + --when vpiVectorVal=> mVector: p_vpi_vecval; + --when vpiStrengthVal=> mStrength: p_vpi_strengthval; + when others => + null; + end case; + end record; + type p_vpi_value is access s_vpi_value; + + --typedef struct t_cb_data { + -- int reason; + -- int (*cb_rtn)(struct t_cb_data*cb); + -- vpiHandle obj; + -- p_vpi_time time; + -- p_vpi_value value; + -- int index; + -- char*user_data; + --} s_cb_data, *p_cb_data; + type s_cb_data; + + type p_cb_data is access all s_cb_data; + function To_p_cb_data is new Ada.Unchecked_Conversion + (Source => Address, Target => p_cb_data); + + type cb_rtn_type is access function (Cb : p_cb_data) return Integer; + pragma Convention (C, cb_rtn_type); + + type s_cb_data is record + Reason : Integer; + Cb_Rtn : cb_rtn_type; + Obj : vpiHandle; + Time : p_vpi_time; + Value : p_vpi_value; + Index : Integer; + User_Data : Address; + end record; + + type struct_vpiHandle (mType : Integer := vpiUndefined) is record + case mType is + when vpiCallback => + Cb : p_cb_data; + when others => + Ref : VhpiHandleT; + end case; + end record; + + -- vpiHandle vpi_iterate(int type, vpiHandle ref) + function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle; + pragma Export (C, vpi_iterate, "vpi_iterate"); + + -- int vpi_get(int property, vpiHandle ref) + function vpi_get (Property : Integer; Ref : vpiHandle) return Integer; + pragma Export (C, vpi_get, "vpi_get"); + + -- vpiHandle vpi_scan(vpiHandle iter) + function vpi_scan (Iter : vpiHandle) return vpiHandle; + pragma Export (C, vpi_scan, "vpi_scan"); + + -- char *vpi_get_str(int property, vpiHandle ref) + function vpi_get_str (Property : Integer; Ref : vpiHandle) + return Ghdl_C_String; + pragma Export (C, vpi_get_str, "vpi_get_str"); + + -- vpiHandle vpi_handle(int type, vpiHandle ref) + function vpi_handle (aType: integer; Ref: vpiHandle) + return vpiHandle; + pragma Export (C, vpi_handle, "vpi_handle"); + + -- void vpi_get_value(vpiHandle expr, p_vpi_value value); + procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value); + pragma Export (C, vpi_get_value, "vpi_get_value"); + + -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); + procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time); + pragma Export (C, vpi_get_time, "vpi_get_time"); + + -- vpiHandle vpi_register_cb(p_cb_data data) + function vpi_register_cb (Data : p_cb_data) return vpiHandle; + pragma Export (C, vpi_register_cb, "vpi_register_cb"); + +------------------------------------------------------------------------------- +-- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + -- int vpi_free_object(vpiHandle ref) + function vpi_free_object(aRef: vpiHandle) return integer; + pragma Export (C, vpi_free_object, "vpi_free_object"); + + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) + function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer; + pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info"); + + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) + function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) + return vpiHandle; + pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index"); + + -- unsigned int vpi_mcd_close(unsigned int mcd) + function vpi_mcd_close (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_close, "vpi_mcd_close"); + + -- char *vpi_mcd_name(unsigned int mcd) + function vpi_mcd_name (Mcd : Integer) return Integer; + pragma Export (C, vpi_mcd_name, "vpi_mcd_name"); + + -- unsigned int vpi_mcd_open(char *name) + function vpi_mcd_open (Name : Ghdl_C_String) return Integer; + pragma Export (C, vpi_mcd_open, "vpi_mcd_open"); + + -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, + -- p_vpi_time when, int flags) + function vpi_put_value (aObj : vpiHandle; + aValue : p_vpi_value; + aWhen : p_vpi_time; + aFlags : integer) + return vpiHandle; + pragma Export (C, vpi_put_value, "vpi_put_value"); + + -- void vpi_register_systf(const struct t_vpi_systf_data*ss) + procedure vpi_register_systf (aSs : Address); + pragma Export (C, vpi_register_systf, "vpi_register_systf"); + + -- int vpi_remove_cb(vpiHandle ref) + function vpi_remove_cb (Ref : vpiHandle) return integer; + pragma Export (C, vpi_remove_cb, "vpi_remove_cb"); + + -- void vpi_vprintf(const char*fmt, va_list ap) + procedure vpi_vprintf (Fmt: Address; Ap: Address); + pragma Export (C, vpi_vprintf, "vpi_vprintf"); + +------------------------------------------------------------------------------- +-- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * +------------------------------------------------------------------------------- + + procedure Register; + +end Grt.Vpi; + diff --git a/src/translate/grt/grt-vstrings.adb b/src/translate/grt/grt-vstrings.adb new file mode 100644 index 0000000..30c58ab --- /dev/null +++ b/src/translate/grt/grt-vstrings.adb @@ -0,0 +1,422 @@ +-- GHDL Run Time (GRT) - variable strings. +-- 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.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Errors; use Grt.Errors; +with Grt.C; use Grt.C; + +package body Grt.Vstrings is + procedure Free (Fs : Fat_String_Acc); + pragma Import (C, Free); + + function Malloc (Len : Natural) return Fat_String_Acc; + pragma Import (C, Malloc); + + function Realloc (Ptr : Fat_String_Acc; Len : Natural) + return Fat_String_Acc; + pragma Import (C, Realloc); + + + procedure Free (Vstr : in out Vstring) is + begin + Free (Vstr.Str); + Vstr := (Str => null, + Max => 0, + Len => 0); + end Free; + + procedure Grow (Vstr : in out Vstring; Sum : Natural) + is + Nlen : constant Natural := Vstr.Len + Sum; + Nmax : Natural; + begin + Vstr.Len := Nlen; + if Nlen <= Vstr.Max then + return; + end if; + if Vstr.Max = 0 then + Nmax := 32; + else + Nmax := Vstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Vstr.Str := Realloc (Vstr.Str, Nmax); + if Vstr.Str = null then + Internal_Error ("grt.vstrings.grow: memory exhausted"); + end if; + Vstr.Max := Nmax; + end Grow; + + procedure Append (Vstr : in out Vstring; C : Character) + is + begin + Grow (Vstr, 1); + Vstr.Str (Vstr.Len) := C; + end Append; + + procedure Append (Vstr : in out Vstring; Str : String) + is + S : constant Natural := Vstr.Len; + begin + Grow (Vstr, Str'Length); + Vstr.Str (S + 1 .. S + Str'Length) := Str; + end Append; + + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String) + is + S : constant Natural := Vstr.Len; + L : constant Natural := strlen (Str); + begin + Grow (Vstr, L); + Vstr.Str (S + 1 .. S + L) := Str (1 .. L); + end Append; + + function Length (Vstr : Vstring) return Natural is + begin + return Vstr.Len; + end Length; + + procedure Truncate (Vstr : in out Vstring; Len : Natural) is + begin + if Len > Vstr.Len then + Internal_Error ("grt.vstrings.truncate: bad len"); + end if; + Vstr.Len := Len; + end Truncate; + + procedure Put (Stream : FILEs; Vstr : Vstring) + is + S : size_t; + begin + S := size_t (Vstr.Len); + if S > 0 then + S := fwrite (Vstr.Str (1)'Address, S, 1, Stream); + end if; + end Put; + + procedure Free (Rstr : in out Rstring) is + begin + Free (Rstr.Str); + Rstr := (Str => null, + Max => 0, + First => 0); + end Free; + + function Length (Rstr : Rstring) return Natural is + begin + return Rstr.Max + 1 - Rstr.First; + end Length; + + procedure Grow (Rstr : in out Rstring; Min : Natural) + is + Len : constant Natural := Length (Rstr); + Nlen : constant Natural := Len + Min; + Nstr : Fat_String_Acc; + Nfirst : Natural; + Nmax : Natural; + begin + if Nlen <= Rstr.Max then + return; + end if; + if Rstr.Max = 0 then + Nmax := 32; + else + Nmax := Rstr.Max; + end if; + while Nmax < Nlen loop + Nmax := Nmax * 2; + end loop; + Nstr := Malloc (Nmax); + Nfirst := Nmax + 1 - Len; + if Rstr.Str /= null then + Nstr (Nfirst .. Nmax) := Rstr.Str (Rstr.First .. Rstr.Max); + Free (Rstr.Str); + end if; + Rstr := (Str => Nstr, + Max => Nmax, + First => Nfirst); + end Grow; + + procedure Prepend (Rstr : in out Rstring; C : Character) + is + begin + Grow (Rstr, 1); + Rstr.First := Rstr.First - 1; + Rstr.Str (Rstr.First) := C; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : String) + is + begin + Grow (Rstr, Str'Length); + Rstr.First := Rstr.First - Str'Length; + Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1) := Str; + end Prepend; + + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String) + is + L : constant Natural := strlen (Str); + begin + Grow (Rstr, L); + Rstr.First := Rstr.First - L; + Rstr.Str (Rstr.First .. Rstr.First + L - 1) := Str (1 .. L); + end Prepend; + + function Get_Address (Rstr : Rstring) return Address + is + begin + return Rstr.Str (Rstr.First)'Address; + end Get_Address; + + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural) + is + begin + Len := Length (Rstr); + if Len > Str'Length then + Str := Rstr.Str (Rstr.First .. Rstr.First + Str'Length - 1); + else + Str (Str'First .. Str'First + Len - 1) := + Rstr.Str (Rstr.First .. Rstr.First + Len - 1); + end if; + end Copy; + + procedure Put (Stream : FILEs; Rstr : Rstring) + is + S : size_t; + pragma Unreferenced (S); + begin + S := fwrite (Get_Address (Rstr), size_t (Length (Rstr)), 1, Stream); + end Put; + + generic + type Ntype is range <>; + --Max_Len : Natural; + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype); + + procedure Gen_To_String (Str : out String; First : out Natural; N : Ntype) + is + subtype R_Type is String (1 .. Str'Length); + S : R_Type renames Str; + P : Natural := S'Last; + V : Ntype; + begin + if N > 0 then + V := -N; + else + V := N; + end if; + loop + S (P) := Character'Val (48 - (V rem 10)); + V := V / 10; + exit when V = 0; + P := P - 1; + end loop; + if N < 0 then + P := P - 1; + S (P) := '-'; + end if; + First := P; + end Gen_To_String; + + procedure To_String_I32 is new Gen_To_String (Ntype => Ghdl_I32); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32) + renames To_String_I32; + + procedure To_String_I64 is new Gen_To_String (Ntype => Ghdl_I64); + + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64) + renames To_String_I64; + + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64) + is + function Trunc (V : Ghdl_F64) return Ghdl_F64; + pragma Import (C, Trunc); + + P : Natural := Str'First; + V : Ghdl_F64; + Vmax : Ghdl_F64; + Vd : Ghdl_F64; + Exp : Integer; + D : Integer; + B : Boolean; + begin + -- Handle sign. + if N < 0.0 then + Str (P) := '-'; + P := P + 1; + V := -N; + else + V := N; + end if; + + -- Compute the mantissa. + -- and normalize V in [0 .. 10.0[ + -- FIXME: should do a dichotomy. + if V = 0.0 then + Exp := 0; + elsif V < 1.0 then + Exp := 0; + loop + exit when V >= 1.0; + Exp := Exp - 1; + V := V * 10.0; + end loop; + else + Exp := 0; + loop + exit when V < 10.0; + Exp := Exp + 1; + V := V / 10.0; + end loop; + end if; + + Vmax := 10.0 ** (1 - 15); + for I in 0 .. 15 loop + -- Vd := Ghdl_F64'Truncation (V); + Vd := Trunc (V); + Str (P) := Character'Val (48 + Integer (Vd)); + P := P + 1; + V := (V - Vd) * 10.0; + + if I = 0 then + Str (P) := '.'; + P := P + 1; + end if; + exit when I > 0 and V < Vmax; + Vmax := Vmax * 10.0; + end loop; + + if Exp /= 0 then + -- LRM93 14.3 + -- if the exponent is present, the `e' is written as a lower case + -- character. + Str (P) := 'e'; + P := P + 1; + + if Exp < 0 then + Str (P) := '-'; + P := P + 1; + Exp := -Exp; + end if; + B := False; + for I in 0 .. 4 loop + D := (Exp / 10000) mod 10; + if D /= 0 or B or I = 4 then + Str (P) := Character'Val (48 + D); + P := P + 1; + B := True; + end if; + Exp := (Exp - D * 10000) * 10; + end loop; + end if; + + Last := P - 1; + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32) + is + procedure Snprintf_Nf (Str : in out String; + Len : Natural; + Ndigits : Ghdl_I32; + V : Ghdl_F64); + pragma Import (C, Snprintf_Nf, "__ghdl_snprintf_nf"); + begin + Snprintf_Nf (Str, Str'Length, Nbr_Digits, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String) + is + procedure Snprintf_Fmtf (Str : in out String; + Len : Natural; + Format : Ghdl_C_String; + V : Ghdl_F64); + pragma Import (C, Snprintf_Fmtf, "__ghdl_snprintf_fmtf"); + begin + -- FIXME: check format ('%', f/g/e/a) + Snprintf_Fmtf (Str, Str'Length, Format, N); + Last := strlen (To_Ghdl_C_String (Str'Address)); + end To_String; + + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64) + is + V, U : Ghdl_I64; + D : Natural; + P : Natural := Str'Last; + Has_Digits : Boolean; + begin + -- Always work on negative values. + if Value > 0 then + V := -Value; + else + V := Value; + end if; + + Has_Digits := False; + U := Unit; + loop + if U = 1 then + if Has_Digits then + Str (P) := '.'; + P := P - 1; + else + Has_Digits := True; + end if; + end if; + + D := Natural (-(V rem 10)); + if D /= 0 or else Has_Digits then + Str (P) := Character'Val (48 + D); + P := P - 1; + Has_Digits := True; + end if; + U := U / 10; + V := V / 10; + exit when V = 0 and then U = 0; + end loop; + if not Has_Digits then + Str (P) := '0'; + else + P := P + 1; + end if; + if Value < 0 then + P := P - 1; + Str (P) := '-'; + end if; + First := P; + end To_String; +end Grt.Vstrings; diff --git a/src/translate/grt/grt-vstrings.ads b/src/translate/grt/grt-vstrings.ads new file mode 100644 index 0000000..94967bb --- /dev/null +++ b/src/translate/grt/grt-vstrings.ads @@ -0,0 +1,143 @@ +-- GHDL Run Time (GRT) - variable strings. +-- 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.Stdio; use Grt.Stdio; +with Grt.Types; use Grt.Types; +with System; use System; + +package Grt.Vstrings is + -- A Vstring (Variable string) is an object which contains an unbounded + -- string. + type Vstring is limited private; + + -- Deallocate all storage internally allocated. + procedure Free (Vstr : in out Vstring); + + -- Append a character. + procedure Append (Vstr : in out Vstring; C : Character); + + -- Append a string. + procedure Append (Vstr : in out Vstring; Str : String); + + -- Append a C string. + procedure Append (Vstr : in out Vstring; Str : Ghdl_C_String); + + -- Get length of VSTR. + function Length (Vstr : Vstring) return Natural; + + -- Truncate VSTR to LEN. + -- It is an error if LEN is greater than the current length. + procedure Truncate (Vstr : in out Vstring; Len : Natural); + + -- Display VSTR. + procedure Put (Stream : FILEs; Vstr : Vstring); + + + -- A Rstring is link a Vstring but characters can only be prepended. + type Rstring is limited private; + + -- Deallocate storage associated with Rstr. + procedure Free (Rstr : in out Rstring); + + -- Prepend characters or strings. + procedure Prepend (Rstr : in out Rstring; C : Character); + procedure Prepend (Rstr : in out Rstring; Str : String); + procedure Prepend (Rstr : in out Rstring; Str : Ghdl_C_String); + + -- Get the length of RSTR. + function Length (Rstr : Rstring) return Natural; + + -- Return the address of the first character of RSTR. + function Get_Address (Rstr : Rstring) return Address; + + -- Display RSTR. + procedure Put (Stream : FILEs; Rstr : Rstring); + + -- Copy RSTR to STR, and return length of the string to LEN. + procedure Copy (Rstr : Rstring; Str : in out String; Len : out Natural); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 11 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I32); + + -- Write the image of N into STR padded to the right. FIRST is the index + -- of the first character, so the result is in STR (FIRST .. STR'last). + -- Requires at least 21 characters. + procedure To_String (Str : out String; First : out Natural; N : Ghdl_I64); + + -- Write the image of N into STR. LAST is the index of the last character, + -- so the result is in STR (STR'first .. LAST). + -- Requires at least 24 characters. + -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) + -- + exp_digits (4) -> 24. + procedure To_String (Str : out String; Last : out Natural; N : Ghdl_F64); + + subtype String_Real_Digits is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Nbr_Digits : Ghdl_I32); + + subtype String_Real_Format is String (1 .. 128); + + -- Write the image of N into STR using NBR_DIGITS digits after the decimal + -- point. + procedure To_String (Str : out String_Real_Digits; + Last : out Natural; + N : Ghdl_F64; + Format : Ghdl_C_String); + + -- Write the image of VALUE to STR using UNIT as unit. The output is in + -- STR (FIRST .. STR'last). + subtype String_Time_Unit is String (1 .. 22); + procedure To_String (Str : out String_Time_Unit; + First : out Natural; + Value : Ghdl_I64; + Unit : Ghdl_I64); + +private + subtype Fat_String is String (Positive); + type Fat_String_Acc is access Fat_String; + + type Vstring is record + Str : Fat_String_Acc := null; + Max : Natural := 0; + Len : Natural := 0; + end record; + + type Rstring is record + -- String whose bounds is (1 .. Max). + Str : Fat_String_Acc := null; + + -- Last index in STR. + Max : Natural := 0; + + -- Index of the first character. + First : Natural := 1; + end record; +end Grt.Vstrings; diff --git a/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb new file mode 100644 index 0000000..63bdb9a --- /dev/null +++ b/src/translate/grt/grt-waves.adb @@ -0,0 +1,1632 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- 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 Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with Interfaces; use Interfaces; +with System.Storage_Elements; -- Work around GNAT bug. +pragma Unreferenced (System.Storage_Elements); +with Grt.Types; use Grt.Types; +with Grt.Avhpi; use Grt.Avhpi; +with Grt.Stdio; use Grt.Stdio; +with Grt.C; use Grt.C; +with Grt.Errors; use Grt.Errors; +with Grt.Astdio; use Grt.Astdio; +with Grt.Hooks; use Grt.Hooks; +with Grt.Table; +with Grt.Avls; use Grt.Avls; +with Grt.Rtis; use Grt.Rtis; +with Grt.Rtis_Addr; use Grt.Rtis_Addr; +with Grt.Rtis_Utils; +with Grt.Rtis_Types; +with Grt.Signals; use Grt.Signals; +with System; use System; +with Grt.Vstrings; use Grt.Vstrings; + +pragma Elaborate_All (Grt.Rtis_Utils); +pragma Elaborate_All (Grt.Table); + +package body Grt.Waves is + -- Waves filename. + Wave_Filename : String_Access := null; + -- Stream corresponding to the GHW filename. + Wave_Stream : FILEs; + + Ghw_Hie_Design : constant Unsigned_8 := 1; + Ghw_Hie_Block : constant Unsigned_8 := 3; + Ghw_Hie_Generate_If : constant Unsigned_8 := 4; + Ghw_Hie_Generate_For : constant Unsigned_8 := 5; + Ghw_Hie_Instance : constant Unsigned_8 := 6; + Ghw_Hie_Package : constant Unsigned_8 := 7; + Ghw_Hie_Process : constant Unsigned_8 := 13; + Ghw_Hie_Generic : constant Unsigned_8 := 14; + Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope. + Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal. + Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port + Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port + Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port + Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port + Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port + + pragma Unreferenced (Ghw_Hie_Design); + pragma Unreferenced (Ghw_Hie_Generic); + + -- Return TRUE if OPT is an option for wave. + function Wave_Option (Opt : String) return Boolean + is + F : constant Natural := Opt'First; + begin + if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then + return False; + end if; + if Opt'Length > 6 and then Opt (F + 6) = '=' then + -- Add an extra NUL character. + Wave_Filename := new String (1 .. Opt'Length - 7 + 1); + Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last); + Wave_Filename (Wave_Filename'Last) := NUL; + return True; + else + return False; + end if; + end Wave_Option; + + procedure Wave_Help is + begin + Put_Line (" --wave=FILENAME dump signal values into a wave file"); + end Wave_Help; + + procedure Wave_Put (Str : String) + is + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); + end Wave_Put; + + procedure Wave_Putc (C : Character) + is + R : int; + pragma Unreferenced (R); + begin + R := fputc (Character'Pos (C), Wave_Stream); + end Wave_Putc; + + procedure Wave_Newline is + begin + Wave_Putc (Nl); + end Wave_Newline; + + procedure Wave_Put_Byte (B : Unsigned_8) + is + V : Unsigned_8 := B; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 1, 1, Wave_Stream); + end Wave_Put_Byte; + + procedure Wave_Put_ULEB128 (Val : Ghdl_E32) + is + V : Ghdl_E32; + R : Ghdl_E32; + begin + V := Val; + loop + R := V mod 128; + V := V / 128; + if V = 0 then + Wave_Put_Byte (Unsigned_8 (R)); + exit; + else + Wave_Put_Byte (Unsigned_8 (128 + R)); + end if; + end loop; + end Wave_Put_ULEB128; + + procedure Wave_Put_SLEB128 (Val : Ghdl_I32) + is + function To_Ghdl_U32 is new Ada.Unchecked_Conversion + (Ghdl_I32, Ghdl_U32); + V : Ghdl_U32 := To_Ghdl_U32 (Val); + +-- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural) +-- return Ghdl_U32; +-- pragma Import (Intrinsic, Shift_Right_Arithmetic); + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_SLEB128; + + procedure Wave_Put_LSLEB128 (Val : Ghdl_I64) + is + function To_Ghdl_U64 is new Ada.Unchecked_Conversion + (Ghdl_I64, Ghdl_U64); + V : Ghdl_U64 := To_Ghdl_U64 (Val); + + R : Unsigned_8; + begin + loop + R := Unsigned_8 (V mod 128); + V := Shift_Right_Arithmetic (V, 7); + if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) + then + Wave_Put_Byte (R); + exit; + else + Wave_Put_Byte (R or 16#80#); + end if; + end loop; + end Wave_Put_LSLEB128; + + procedure Wave_Put_I32 (Val : Ghdl_I32) + is + V : Ghdl_I32 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 4, 1, Wave_Stream); + end Wave_Put_I32; + + procedure Wave_Put_I64 (Val : Ghdl_I64) + is + V : Ghdl_I64 := Val; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, 8, 1, Wave_Stream); + end Wave_Put_I64; + + procedure Wave_Put_F64 (F64 : Ghdl_F64) + is + V : Ghdl_F64 := F64; + R : size_t; + pragma Unreferenced (R); + begin + R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); + end Wave_Put_F64; + + procedure Wave_Puts (Str : Ghdl_C_String) is + begin + Put (Wave_Stream, Str); + end Wave_Puts; + + procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is + begin + case Mode is + when Mode_B1 => + Wave_Put_Byte (Ghdl_B1'Pos (Value.B1)); + when Mode_E8 => + Wave_Put_Byte (Ghdl_E8'Pos (Value.E8)); + when Mode_E32 => + Wave_Put_ULEB128 (Value.E32); + when Mode_I32 => + Wave_Put_SLEB128 (Value.I32); + when Mode_I64 => + Wave_Put_LSLEB128 (Value.I64); + when Mode_F64 => + Wave_Put_F64 (Value.F64); + end case; + end Write_Value; + + subtype Section_Name is String (1 .. 4); + type Header_Type is record + Name : Section_Name; + Pos : long; + end record; + + package Section_Table is new Grt.Table + (Table_Component_Type => Header_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 16); + + -- Create a new section. + -- Write the header in the file. + -- Save the location for the directory. + procedure Wave_Section (Name : Section_Name) is + begin + Section_Table.Append (Header_Type'(Name => Name, + Pos => ftell (Wave_Stream))); + Wave_Put (Name); + end Wave_Section; + + procedure Wave_Write_Size_Order is + begin + -- Byte order, 1 byte. + -- 0: bad, 1 : little-endian, 2 : big endian. + declare + type Byte_Arr is array (0 .. 3) of Unsigned_8; + function To_Byte_Arr is new Ada.Unchecked_Conversion + (Source => Unsigned_32, Target => Byte_Arr); + B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#); + V : Unsigned_8; + begin + if B4 (0) = 16#11# then + -- Big endian. + V := 2; + elsif B4 (0) = 16#44# then + -- Little endian. + V := 1; + else + -- Unknown endian. + V := 0; + end if; + Wave_Put_Byte (V); + end; + -- Word size, 1 byte. + Wave_Put_Byte (Integer'Size / 8); + -- File offset size, 1 byte + Wave_Put_Byte (1); + -- Unused, must be zero (MBZ). + Wave_Put_Byte (0); + end Wave_Write_Size_Order; + + procedure Wave_Write_Directory + is + Pos : long; + begin + Pos := ftell (Wave_Stream); + Wave_Section ("DIR" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Section_Table.Last)); + for I in Section_Table.First .. Section_Table.Last loop + Wave_Put (Section_Table.Table (I).Name); + Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos)); + end loop; + Wave_Put ("EOD" & NUL); + + Wave_Section ("TAI" & NUL); + Wave_Write_Size_Order; + Wave_Put_I32 (Ghdl_I32 (Pos)); + end Wave_Write_Directory; + + -- Called before elaboration. + procedure Wave_Init + is + Mode : constant String := "wb" & NUL; + begin + if Wave_Filename = null then + Wave_Stream := NULL_Stream; + return; + end if; + if Wave_Filename.all = "-" & NUL then + Wave_Stream := stdout; + else + Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address); + if Wave_Stream = NULL_Stream then + Error_C ("cannot open "); + Error_E (Wave_Filename (Wave_Filename'First + .. Wave_Filename'Last - 1)); + return; + end if; + end if; + end Wave_Init; + + procedure Write_File_Header + is + begin + -- Magic, 9 bytes. + Wave_Put ("GHDLwave" & Nl); + -- Header length. + Wave_Put_Byte (16); + -- Version-major, 1 byte. + Wave_Put_Byte (0); + -- Version-minor, 1 byte. + Wave_Put_Byte (1); + + Wave_Write_Size_Order; + end Write_File_Header; + + procedure Avhpi_Error (Err : AvhpiErrorT) + is + pragma Unreferenced (Err); + begin + Put_Line ("Waves.Avhpi_Error!"); + null; + end Avhpi_Error; + + package Str_Table is new Grt.Table + (Table_Component_Type => Ghdl_C_String, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Str_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + Strings_Len : Natural := 0; + + function Str_Compare (L, R : AVL_Value) return Integer + is + Ls, Rs : Ghdl_C_String; + begin + Ls := Str_Table.Table (L); + Rs := Str_Table.Table (R); + if L = R then + return 0; + end if; + return Strcmp (Ls, Rs); + end Str_Compare; + + procedure Disp_Str_Avl (N : AVL_Nid) is + begin + Put (stdout, "node: "); + Put_I32 (stdout, Ghdl_I32 (N)); + New_Line (stdout); + Put (stdout, " left: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left)); + New_Line (stdout); + Put (stdout, " right: "); + Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right)); + New_Line (stdout); + Put (stdout, " height: "); + Put_I32 (stdout, Str_AVL.Table (N).Height); + New_Line (stdout); + Put (stdout, " str: "); + --Put (stdout, Str_AVL.Table (N).Val); + New_Line (stdout); + end Disp_Str_Avl; + + pragma Unreferenced (Disp_Str_Avl); + + function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value + is + Res : AVL_Nid; + begin + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + return Str_AVL.Table (Res).Val; + end Create_Str_Index; + + pragma Unreferenced (Create_Str_Index); + + procedure Create_String_Id (Str : Ghdl_C_String) + is + Res : AVL_Nid; + begin + if Str = null then + return; + end if; + Str_Table.Append (Str); + Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), + Str_Compare'Access, + Str_AVL.Last, Res); + if Res /= Str_AVL.Last then + Str_AVL.Decrement_Last; + Str_Table.Decrement_Last; + else + Strings_Len := Strings_Len + strlen (Str); + end if; + end Create_String_Id; + + function Get_String (Str : Ghdl_C_String) return AVL_Value + is + H, L, M : AVL_Value; + Diff : Integer; + begin + L := Str_Table.First; + H := Str_Table.Last; + loop + M := (L + H) / 2; + Diff := Strcmp (Str, Str_Table.Table (M)); + if Diff = 0 then + return M; + elsif Diff < 0 then + H := M - 1; + else + L := M + 1; + end if; + exit when L > H; + end loop; + return 0; + end Get_String; + + procedure Write_String_Id (Str : Ghdl_C_String) is + begin + if Str = null then + Wave_Put_Byte (0); + else + Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str))); + end if; + end Write_String_Id; + + type Type_Node is record + Type_Rti : Ghdl_Rti_Access; + Context : Rti_Context; + end record; + + package Types_Table is new Grt.Table + (Table_Component_Type => Type_Node, + Table_Index_Type => AVL_Value, + Table_Low_Bound => 1, + Table_Initial => 16); + + package Types_AVL is new Grt.Table + (Table_Component_Type => AVL_Node, + Table_Index_Type => AVL_Nid, + Table_Low_Bound => AVL_Root, + Table_Initial => 16); + + function Type_Compare (L, R : AVL_Value) return Integer + is + function To_Ia is new + Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); + + function "<" (L, R : Ghdl_Rti_Access) return Boolean is + begin + return To_Ia (L) < To_Ia (R); + end "<"; + + Ls : Type_Node renames Types_Table.Table (L); + Rs : Type_Node renames Types_Table.Table (R); + begin + if Ls.Type_Rti /= Rs.Type_Rti then + if Ls.Type_Rti < Rs.Type_Rti then + return -1; + else + return 1; + end if; + end if; + if Ls.Context.Block /= Rs.Context.Block then + if Ls.Context.Block < Rs.Context.Block then + return -1; + else + return +1; + end if; + end if; + if Ls.Context.Base /= Rs.Context.Base then + if Ls.Context.Base < Rs.Context.Base then + return -1; + else + return +1; + end if; + end if; + return 0; + end Type_Compare; + + -- Try to find type (RTI, CTXT) in the types_AVL table. + -- The first step is to canonicalize CTXT, so that it is the CTXT of + -- the type (and not a sub-scope of it). + procedure Find_Type (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + N_Ctxt : out Rti_Context; + Id : out AVL_Nid) + is + Depth : Ghdl_Rti_Depth; + begin + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + N_Ctxt := Null_Context; + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal => + N_Ctxt := Ctxt; + when others => + -- Compute the canonical context. + if Rti.Max_Depth < Rti.Depth then + Internal_Error ("grt.waves.find_type"); + end if; + Depth := Rti.Max_Depth; + if Depth = 0 or else Ctxt.Block = null then + N_Ctxt := Null_Context; + else + N_Ctxt := Ctxt; + while N_Ctxt.Block.Depth > Depth loop + N_Ctxt := Get_Parent_Context (N_Ctxt); + end loop; + end if; + end case; + + -- If the type is already known, return now. + -- Otherwise, ID is set to AVL_Nil. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt)); + Id := Find_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_Table.Last); + Types_Table.Decrement_Last; + end Find_Type; + + procedure Write_Type_Id (Tid : AVL_Nid) is + begin + Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val)); + end Write_Type_Id; + + procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res = AVL_Nil then + -- raise Program_Error; + Internal_Error ("write_type_id"); + end if; + Write_Type_Id (Res); + end Write_Type_Id; + + procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + Res : AVL_Nid; + begin + -- Then, create the type. + Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt)); + Types_AVL.Append (AVL_Node'(Val => Types_Table.Last, + Left | Right => AVL_Nil, + Height => 1)); + + Get_Node + (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), + Type_Compare'Access, + Types_AVL.Last, Res); + if Res /= Types_AVL.Last then + --raise Program_Error; + Internal_Error ("wave.create_type(2)"); + end if; + end Add_Type; + + procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + is + N_Ctxt : Rti_Context; + Res : AVL_Nid; + begin + Find_Type (Rti, Ctxt, N_Ctxt, Res); + if Res /= AVL_Nil then + return; + end if; + + -- First, create all the types it depends on. + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Create_String_Id (Enum.Name); + for I in 1 .. Enum.Nbr loop + Create_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : Ghdl_Rtin_Subtype_Array_Acc; + B_Ctxt : Rti_Context; + begin + Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Create_String_Id (Arr.Name); + if Rti_Complex_Type (Rti) then + B_Ctxt := Ctxt; + else + B_Ctxt := N_Ctxt; + end if; + Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Create_String_Id (Arr.Name); + Create_Type (Arr.Element, N_Ctxt); + for I in 1 .. Arr.Nbr_Dim loop + Create_Type (Arr.Indexes (I - 1), N_Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Create_String_Id (Sub.Name); + Create_Type (Sub.Basetype, N_Ctxt); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Create_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit_Name : Ghdl_C_String; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Create_String_Id (Base.Name); + for I in 1 .. Base.Nbr loop + Unit_Name := + Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1)); + Create_String_Id (Unit_Name); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Create_String_Id (Rec.Name); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Create_String_Id (El.Name); + Create_Type (El.Eltype, N_Ctxt); + end loop; + end; + when others => + Internal_Error ("wave.create_type"); +-- Internal_Error ("wave.create_type: does not handle " & +-- Ghdl_Rtik'Image (Rti.Kind)); + end case; + + -- Then, create the type. + Add_Type (Rti, N_Ctxt); + end Create_Type; + + procedure Create_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + Create_Type (Rti, Avhpi_Get_Context (Obj_Type)); + + -- The the signal type is an unconstrained array, also put the object + -- in the type AVL. + -- The real type will be written to the file. + if Rti.Kind = Ghdl_Rtik_Type_Array then + Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + end if; + end Create_Object_Type; + + procedure Write_Object_Type (Obj : VhpiHandleT) + is + Obj_Type : VhpiHandleT; + Error : AvhpiErrorT; + Rti : Ghdl_Rti_Access; + begin + -- Extract type of the signal. + Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Obj_Type); + if Rti.Kind = Ghdl_Rtik_Type_Array then + Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); + else + Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type)); + end if; + end Write_Object_Type; + + procedure Create_Generate_Type (Gen : VhpiHandleT) + is + Iterator : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Create_Object_Type (Iterator); + end Create_Generate_Type; + + procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT) + is + Iter : VhpiHandleT; + Iter_Type : VhpiHandleT; + Error : AvhpiErrorT; + Addr : Address; + Mode : Mode_Type; + Rti : Ghdl_Rti_Access; + begin + -- Extract the iterator. + Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Write_Object_Type (Iter); + + Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + Rti := Avhpi_Get_Rti (Iter_Type); + Addr := Avhpi_Get_Address (Iter); + + case Get_Base_Type (Rti).Kind is + when Ghdl_Rtik_Type_B1 => + Mode := Mode_B1; + when Ghdl_Rtik_Type_E8 => + Mode := Mode_E8; + when Ghdl_Rtik_Type_E32 => + Mode := Mode_E32; + when Ghdl_Rtik_Type_I32 => + Mode := Mode_I32; + when Ghdl_Rtik_Type_I64 => + Mode := Mode_I64; + when Ghdl_Rtik_Type_F64 => + Mode := Mode_F64; + when others => + Internal_Error ("bad iterator type"); + end case; + Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode); + end Write_Generate_Type_And_Value; + + type Step_Type is (Step_Name, Step_Hierarchy); + + Nbr_Scopes : Natural := 0; + Nbr_Scope_Signals : Natural := 0; + Nbr_Dumped_Signals : Natural := 0; + + -- This is only valid during write_hierarchy. + function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural + is + function To_Integer_Address is new Ada.Unchecked_Conversion + (Ghdl_Signal_Ptr, Integer_Address); + begin + return Natural (To_Integer_Address (Sig.Alink)); + end Get_Signal_Number; + + procedure Write_Signal_Number (Val_Addr : Address; + Val_Name : Vstring; + Val_Type : Ghdl_Rti_Access; + Param_Type : Natural) + is + pragma Unreferenced (Val_Name); + pragma Unreferenced (Val_Type); + pragma Unreferenced (Param_Type); + + Num : Natural; + + function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion + (Source => Integer_Address, Target => Ghdl_Signal_Ptr); + Sig : Ghdl_Signal_Ptr; + begin + -- Convert to signal. + Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); + + -- Get signal number. + Num := Get_Signal_Number (Sig); + + -- If the signal number is 0, then assign a valid signal number. + if Num = 0 then + Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1; + Sig.Alink := To_Ghdl_Signal_Ptr + (Integer_Address (Nbr_Dumped_Signals)); + Num := Nbr_Dumped_Signals; + end if; + + -- Do the real job: write the signal number. + Wave_Put_ULEB128 (Ghdl_E32 (Num)); + end Write_Signal_Number; + + procedure Foreach_Scalar_Signal_Number is new + Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, + Process => Write_Signal_Number); + + procedure Write_Signal_Numbers (Decl : VhpiHandleT) + is + Ctxt : Rti_Context; + Sig : Ghdl_Rtin_Object_Acc; + begin + Ctxt := Avhpi_Get_Context (Decl); + Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl)); + Foreach_Scalar_Signal_Number + (Ctxt, Sig.Obj_Type, + Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0); + end Write_Signal_Numbers; + + procedure Write_Hierarchy_El (Decl : VhpiHandleT) + is + Mode2hie : constant array (VhpiModeT) of Unsigned_8 := + (VhpiErrorMode => Ghw_Hie_Signal, + VhpiInMode => Ghw_Hie_Port_In, + VhpiOutMode => Ghw_Hie_Port_Out, + VhpiInoutMode => Ghw_Hie_Port_Inout, + VhpiBufferMode => Ghw_Hie_Port_Buffer, + VhpiLinkageMode => Ghw_Hie_Port_Linkage); + V : Unsigned_8; + begin + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK => + V := Mode2hie (Vhpi_Get_Mode (Decl)); + when VhpiSigDeclK => + V := Ghw_Hie_Signal; + when VhpiForGenerateK => + V := Ghw_Hie_Generate_For; + when VhpiIfGenerateK => + V := Ghw_Hie_Generate_If; + when VhpiBlockStmtK => + V := Ghw_Hie_Block; + when VhpiCompInstStmtK => + V := Ghw_Hie_Instance; + when VhpiProcessStmtK => + V := Ghw_Hie_Process; + when VhpiPackInstK => + V := Ghw_Hie_Package; + when VhpiRootInstK => + V := Ghw_Hie_Instance; + when others => + --raise Program_Error; + Internal_Error ("write_hierarchy_el"); + end case; + Wave_Put_Byte (V); + Write_String_Id (Avhpi_Get_Base_Name (Decl)); + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + Write_Object_Type (Decl); + Write_Signal_Numbers (Decl); + when VhpiForGenerateK => + Write_Generate_Type_And_Value (Decl); + when others => + null; + end case; + end Write_Hierarchy_El; + + -- Create a hierarchy block. + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type); + + procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type) + is + Decl_It : VhpiHandleT; + Decl : VhpiHandleT; + Error : AvhpiErrorT; + begin + Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + -- Extract signals. + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + case Vhpi_Get_Kind (Decl) is + when VhpiPortDeclK + | VhpiSigDeclK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + Nbr_Scope_Signals := Nbr_Scope_Signals + 1; + Create_Object_Type (Decl); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + --Wave_Put_Name (Decl); + --Wave_Newline; + when others => + null; + end case; + end loop; + + -- No sub-scopes for packages. + if Vhpi_Get_Kind (Inst) = VhpiPackInstK then + return; + end if; + + -- Extract sub-scopes. + Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error); + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + loop + Vhpi_Scan (Decl_It, Decl, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Nbr_Scopes := Nbr_Scopes + 1; + + case Vhpi_Get_Kind (Decl) is + when VhpiIfGenerateK + | VhpiForGenerateK + | VhpiBlockStmtK + | VhpiCompInstStmtK => + Wave_Put_Hierarchy_Block (Decl, Step); + when VhpiProcessStmtK => + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Decl)); + when Step_Hierarchy => + Write_Hierarchy_El (Decl); + end case; + when others => + Internal_Error ("wave_put_hierarchy_1"); +-- Wave_Put ("unknown "); +-- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl))); +-- Wave_Newline; + end case; + end loop; + end Wave_Put_Hierarchy_1; + + procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type) + is + begin + case Step is + when Step_Name => + Create_String_Id (Avhpi_Get_Base_Name (Inst)); + if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then + Create_Generate_Type (Inst); + end if; + when Step_Hierarchy => + Write_Hierarchy_El (Inst); + end case; + + Wave_Put_Hierarchy_1 (Inst, Step); + + if Step = Step_Hierarchy then + Wave_Put_Byte (Ghw_Hie_Eos); + end if; + end Wave_Put_Hierarchy_Block; + + procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type) + is + Pack_It : VhpiHandleT; + Pack : VhpiHandleT; + Error : AvhpiErrorT; + begin + -- First packages. + Get_Package_Inst (Pack_It); + loop + Vhpi_Scan (Pack_It, Pack, Error); + exit when Error = AvhpiErrorIteratorEnd; + if Error /= AvhpiErrorOk then + Avhpi_Error (Error); + return; + end if; + + Wave_Put_Hierarchy_Block (Pack, Step); + end loop; + + -- Then top entity. + Wave_Put_Hierarchy_Block (Root, Step); + end Wave_Put_Hierarchy; + + procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural) + is + begin + if Str = AVL_Nil then + return; + end if; + Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1); + for I in 1 .. Indent loop + Wave_Putc (' '); + end loop; + Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val)); +-- Wave_Putc ('('); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Str)); +-- Wave_Putc (')'); +-- Put_I32 (Wave_Stream, Get_Height (Str)); + Wave_Newline; + Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1); + end Disp_Str_AVL; + + procedure Write_Strings + is + begin +-- Wave_Put ("AVL height: "); +-- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root))); +-- Wave_Newline; + Wave_Put ("strings length: "); + Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len)); + Wave_Newline; + Disp_Str_AVL (AVL_Root, 0); + fflush (Wave_Stream); + end Write_Strings; + + pragma Unreferenced (Write_Strings); + + procedure Freeze_Strings + is + type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; + type Str_Table1_Acc is access Str_Table1_Type; + Idx : AVL_Value; + Table1 : Str_Table1_Acc; + + procedure Free is new Ada.Unchecked_Deallocation + (Str_Table1_Type, Str_Table1_Acc); + + procedure Store_Strings (N : AVL_Nid) is + begin + if N = AVL_Nil then + return; + end if; + Store_Strings (Str_AVL.Table (N).Left); + Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val); + Idx := Idx + 1; + Store_Strings (Str_AVL.Table (N).Right); + end Store_Strings; + begin + Table1 := new Str_Table1_Type; + Idx := 1; + Store_Strings (AVL_Root); + Str_Table.Release; + Str_AVL.Free; + for I in Table1.all'Range loop + Str_Table.Table (I) := Table1 (I); + end loop; + Free (Table1); + end Freeze_Strings; + + procedure Write_Strings_Compress + is + Last : Ghdl_C_String; + V : Ghdl_C_String; + L : Natural; + L1 : Natural; + begin + Wave_Section ("STR" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Str_Table.Last)); + Wave_Put_I32 (Ghdl_I32 (Strings_Len)); + for I in Str_Table.First .. Str_Table.Last loop + V := Str_Table.Table (I); + if I = Str_Table.First then + L := 1; + else + Last := Str_Table.Table (I - 1); + + for I in Positive loop + if V (I) /= Last (I) then + L := I; + exit; + end if; + end loop; + L1 := L - 1; + loop + if L1 >= 32 then + Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#); + else + Wave_Put_Byte (Unsigned_8 (L1 mod 32)); + end if; + L1 := L1 / 32; + exit when L1 = 0; + end loop; + end if; + + if Boolean'(False) then + Put ("string "); + Put_I32 (stdout, Ghdl_I32 (I)); + Put (": "); + Put (V); + New_Line; + end if; + + loop + exit when V (L) = NUL; + Wave_Putc (V (L)); + L := L + 1; + end loop; + end loop; + -- Last string length. + Wave_Put_Byte (0); + -- End marker. + Wave_Put ("EOS" & NUL); + end Write_Strings_Compress; + + procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) + is + Kind : Ghdl_Rtik; + begin + Kind := Rti.Kind; + if Kind = Ghdl_Rtik_Subtype_Scalar then + Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind; + end if; + case Kind is + when Ghdl_Rtik_Type_B1 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left)); + Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right)); + when Ghdl_Rtik_Type_E8 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Left)); + Wave_Put_Byte (Unsigned_8 (Rng.E8.Right)); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#); + Wave_Put_SLEB128 (Rng.I32.Left); + Wave_Put_SLEB128 (Rng.I32.Right); + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_I64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#); + Wave_Put_LSLEB128 (Rng.P64.Left); + Wave_Put_LSLEB128 (Rng.P64.Right); + when Ghdl_Rtik_Type_F64 => + Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) + + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#); + Wave_Put_F64 (Rng.F64.Left); + Wave_Put_F64 (Rng.F64.Right); + when others => + Internal_Error ("waves.write_range: unhandled kind"); + --Internal_Error ("waves.write_range: unhandled kind " + -- & Ghdl_Rtik'Image (Kind)); + end case; + end Write_Range; + + procedure Write_Types + is + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + begin + Wave_Section ("TYP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Types_Table.Last)); + for I in Types_Table.First .. Types_Table.Last loop + Rti := Types_Table.Table (I).Type_Rti; + Ctxt := Types_Table.Table (I).Context; + + if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then + declare + Obj_Rti : constant Ghdl_Rtin_Object_Acc := + To_Ghdl_Rtin_Object_Acc (Rti); + Arr : constant Ghdl_Rtin_Type_Array_Acc := + To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); + Addr : Ghdl_Uc_Array_Acc; + begin + Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array)); + Write_String_Id (null); + Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); + Addr := To_Ghdl_Uc_Array_Acc + (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); + declare + Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1); + begin + Bound_To_Range (Addr.Bounds, Arr, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Indexes (I), Rngs (I)); + end loop; + end; + end; + else + -- Kind. + Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind)); + case Rti.Kind is + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 => + declare + Enum : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Write_String_Id (Enum.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr)); + for I in 1 .. Enum.Nbr loop + Write_String_Id (Enum.Names (I - 1)); + end loop; + end; + when Ghdl_Rtik_Subtype_Array => + declare + Arr : Ghdl_Rtin_Subtype_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt); + declare + Rngs : Ghdl_Range_Array + (0 .. Arr.Basetype.Nbr_Dim - 1); + begin + Bound_To_Range + (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt), + Arr.Basetype, Rngs); + for I in Rngs'Range loop + Write_Range (Arr.Basetype.Indexes (I), Rngs (I)); + end loop; + end; + end; + when Ghdl_Rtik_Type_Array => + declare + Arr : Ghdl_Rtin_Type_Array_Acc; + begin + Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); + Write_String_Id (Arr.Name); + Write_Type_Id (Arr.Element, Ctxt); + Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim)); + for I in 1 .. Arr.Nbr_Dim loop + Write_Type_Id (Arr.Indexes (I - 1), Ctxt); + end loop; + end; + when Ghdl_Rtik_Type_Record => + declare + Rec : Ghdl_Rtin_Type_Record_Acc; + El : Ghdl_Rtin_Element_Acc; + begin + Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); + Write_String_Id (Rec.Name); + Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel)); + for I in 1 .. Rec.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); + Write_String_Id (El.Name); + Write_Type_Id (El.Eltype, Ctxt); + end loop; + end; + when Ghdl_Rtik_Subtype_Scalar => + declare + Sub : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); + Write_String_Id (Sub.Name); + Write_Type_Id (Sub.Basetype, Ctxt); + Write_Range + (Sub.Basetype, + To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, + Sub.Range_Loc, + Ctxt))); + end; + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 + | Ghdl_Rtik_Type_F64 => + declare + Base : Ghdl_Rtin_Type_Scalar_Acc; + begin + Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); + Write_String_Id (Base.Name); + end; + when Ghdl_Rtik_Type_P32 + | Ghdl_Rtik_Type_P64 => + declare + Base : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Write_String_Id (Base.Name); + Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); + for I in 1 .. Base.Nbr loop + Unit := Base.Units (I - 1); + Write_String_Id + (Rtis_Utils.Get_Physical_Unit_Name (Unit)); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Rti.Kind is + when Ghdl_Rtik_Type_P64 => + Wave_Put_LSLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I64); + when Ghdl_Rtik_Type_P32 => + Wave_Put_SLEB128 + (To_Ghdl_Rtin_Unitptr_Acc (Unit). + Addr.I32); + when others => + Internal_Error + ("wave.write_types(P32/P64-1)"); + end case; + when others => + Internal_Error + ("wave.write_types(P32/P64-2)"); + end case; + end loop; + end; + when others => + Internal_Error ("wave.write_types"); + -- Internal_Error ("wave.write_types: does not handle " & + -- Ghdl_Rtik'Image (Rti.Kind)); + end case; + end if; + end loop; + Wave_Put_Byte (0); + end Write_Types; + + procedure Write_Known_Types + is + use Grt.Rtis_Types; + + Boolean_Type_Id : AVL_Nid; + Bit_Type_Id : AVL_Nid; + Std_Ulogic_Type_Id : AVL_Nid; + + function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid + is + Ctxt : Rti_Context; + Tid : AVL_Nid; + begin + Find_Type (Rti, Null_Context, Ctxt, Tid); + return Tid; + end Search_Type_Id; + begin + Search_Types_RTI; + + Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr); + + Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr); + + if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then + Std_Ulogic_Type_Id := Search_Type_Id + (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr); + else + Std_Ulogic_Type_Id := AVL_Nil; + end if; + + Wave_Section ("WKT" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + + if Boolean_Type_Id /= AVL_Nil then + Wave_Put_Byte (1); + Write_Type_Id (Boolean_Type_Id); + end if; + + if Bit_Type_Id /= AVL_Nil then + Wave_Put_Byte (2); + Write_Type_Id (Bit_Type_Id); + end if; + + if Std_Ulogic_Type_Id /= AVL_Nil then + Wave_Put_Byte (3); + Write_Type_Id (Std_Ulogic_Type_Id); + end if; + + Wave_Put_Byte (0); + end Write_Known_Types; + + -- Table of signals to be dumped. + package Dump_Table is new Grt.Table + (Table_Component_Type => Ghdl_Signal_Ptr, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 32); + + function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is + begin + return Dump_Table.Table (N); + end Get_Dump_Entry; + + pragma Unreferenced (Get_Dump_Entry); + + procedure Write_Hierarchy (Root : VhpiHandleT) + is + N : Natural; + begin + -- Check Alink is 0. + for I in Sig_Table.First .. Sig_Table.Last loop + if Sig_Table.Table (I).Alink /= null then + Internal_Error ("wave.write_hierarchy"); + end if; + end loop; + + Wave_Section ("HIE" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes)); + Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals)); + Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); + Wave_Put_Hierarchy (Root, Step_Hierarchy); + Wave_Put_Byte (0); + + Dump_Table.Set_Last (Nbr_Dumped_Signals); + for I in Dump_Table.First .. Dump_Table.Last loop + Dump_Table.Table (I) := null; + end loop; + + -- Save and clear. + for I in Sig_Table.First .. Sig_Table.Last loop + N := Get_Signal_Number (Sig_Table.Table (I)); + if N /= 0 then + if Dump_Table.Table (N) /= null then + Internal_Error ("wave.write_hierarchy(2)"); + end if; + Dump_Table.Table (N) := Sig_Table.Table (I); + Sig_Table.Table (I).Alink := null; + end if; + end loop; + end Write_Hierarchy; + + procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is + begin + -- FIXME: for some signals, the significant value is the driving value! + Write_Value (Sig.Value, Sig.Mode); + end Write_Signal_Value; + + procedure Write_Snapshot is + begin + Wave_Section ("SNP" & NUL); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_Byte (0); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + + for I in Dump_Table.First .. Dump_Table.Last loop + Write_Signal_Value (Dump_Table.Table (I)); + end loop; + Wave_Put ("ESN" & NUL); + end Write_Snapshot; + + procedure Wave_Cycle; + + -- Called after elaboration. + procedure Wave_Start + is + Root : VhpiHandleT; + begin + -- Do nothing if there is no VCD file to generate. + if Wave_Stream = NULL_Stream then + return; + end if; + + Write_File_Header; + + -- FIXME: write infos + -- * date + -- * timescale + -- * design name ? + -- ... + + -- Put hierarchy. + Get_Root_Inst (Root); + -- Vcd_Search_Packages; + Wave_Put_Hierarchy (Root, Step_Name); + + Freeze_Strings; + + -- Register_Cycle_Hook (Vcd_Cycle'Access); + Write_Strings_Compress; + Write_Types; + Write_Known_Types; + Write_Hierarchy (Root); + + -- End of header mark. + Wave_Section ("EOH" & NUL); + + Write_Snapshot; + + Register_Cycle_Hook (Wave_Cycle'Access); + + fflush (Wave_Stream); + end Wave_Start; + + Wave_Time : Std_Time := 0; + In_Cyc : Boolean := False; + + procedure Wave_Close_Cyc + is + begin + Wave_Put_LSLEB128 (-1); + Wave_Put ("ECY" & NUL); + In_Cyc := False; + end Wave_Close_Cyc; + + procedure Wave_Cycle + is + Diff : Std_Time; + Sig : Ghdl_Signal_Ptr; + Last : Natural; + begin + if not In_Cyc then + Wave_Section ("CYC" & NUL); + Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + In_Cyc := True; + else + Diff := Cycle_Time - Wave_Time; + Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); + end if; + Wave_Time := Cycle_Time; + + -- Dump signals. + Last := 0; + for I in Dump_Table.First .. Dump_Table.Last loop + Sig := Dump_Table.Table (I); + if Sig.Flags.Cyc_Event then + Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); + Last := I; + Write_Signal_Value (Sig); + Sig.Flags.Cyc_Event := False; + end if; + end loop; + Wave_Put_Byte (0); + end Wave_Cycle; + + -- Called at the end of the simulation. + procedure Wave_End is + begin + if Wave_Stream = NULL_Stream then + return; + end if; + if In_Cyc then + Wave_Close_Cyc; + end if; + Wave_Write_Directory; + fflush (Wave_Stream); + end Wave_End; + + Wave_Hooks : aliased constant Hooks_Type := + (Option => Wave_Option'Access, + Help => Wave_Help'Access, + Init => Wave_Init'Access, + Start => Wave_Start'Access, + Finish => Wave_End'Access); + + procedure Register is + begin + Register_Hooks (Wave_Hooks'Access); + end Register; +end Grt.Waves; diff --git a/src/translate/grt/grt-waves.ads b/src/translate/grt/grt-waves.ads new file mode 100644 index 0000000..72d7ea6 --- /dev/null +++ b/src/translate/grt/grt-waves.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - wave dumper (GHW) module. +-- 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. +package Grt.Waves is + procedure Register; +end Grt.Waves; diff --git a/src/translate/grt/grt-zlib.ads b/src/translate/grt/grt-zlib.ads new file mode 100644 index 0000000..9dfee36 --- /dev/null +++ b/src/translate/grt/grt-zlib.ads @@ -0,0 +1,47 @@ +-- GHDL Run Time (GRT) - Zlib binding. +-- Copyright (C) 2005 - 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 Grt.C; use Grt.C; + +package Grt.Zlib is + pragma Linker_Options ("-lz"); + + type gzFile is new System.Address; + + NULL_gzFile : constant gzFile := gzFile (System'To_Address (0)); + + function gzputc (File : gzFile; C : int) return int; + pragma Import (C, gzputc); + + function gzwrite (File : gzFile; Buf : voids; Len : int) return int; + pragma Import (C, gzwrite); + + function gzopen (Path : chars; Mode : chars) return gzFile; + pragma Import (C, gzopen); + + procedure gzclose (File : gzFile); + pragma Import (C, gzclose); +end Grt.Zlib; diff --git a/src/translate/grt/grt.adc b/src/translate/grt/grt.adc new file mode 100644 index 0000000..f228499 --- /dev/null +++ b/src/translate/grt/grt.adc @@ -0,0 +1,46 @@ +-- GHDL Run Time (GRT) - Configuration pragmas. +-- 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. + +-- The GRT library is built with a lot of restrictions. +-- The purpose of these restrictions (mainly No_Run_Time) is not to link with +-- the GNAT run time library. The user does not need to download or compile +-- it. +-- +-- However, GRT works without these restrictions. If you want to use GRT +-- in Ada, you may compile GRT without these restrictions (remove the -gnatec +-- flag). +-- +-- This files is *not* names gnat.adc, in order to ease the possibility of +-- not using it. +pragma Restrictions (No_Exception_Handlers); +--pragma restrictions (No_Exceptions); +pragma Restrictions (No_Secondary_Stack); +--pragma Restrictions (No_Elaboration_Code); +pragma Restrictions (No_Io); +pragma restrictions (no_dependence => Ada.Tags); +pragma restrictions (no_dependence => GNAT); +pragma Restrictions (Max_Tasks => 0); +pragma Restrictions (No_Implicit_Heap_Allocations); +pragma No_Run_Time; diff --git a/src/translate/grt/grt.ads b/src/translate/grt/grt.ads new file mode 100644 index 0000000..9727d04 --- /dev/null +++ b/src/translate/grt/grt.ads @@ -0,0 +1,27 @@ +-- GHDL Run Time (GRT) - Top of hierarchy. +-- 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. +package Grt is + pragma Pure (Grt); +end Grt; diff --git a/src/translate/grt/grt.ver b/src/translate/grt/grt.ver new file mode 100644 index 0000000..031c207 --- /dev/null +++ b/src/translate/grt/grt.ver @@ -0,0 +1,25 @@ +{ + global: +vpi_free_object; +vpi_get; +vpi_get_str; +vpi_get_time; +vpi_get_value; +vpi_get_vlog_info; +vpi_handle; +vpi_handle_by_index; +vpi_iterate; +vpi_mcd_close; +vpi_mcd_name; +vpi_mcd_open; +vpi_put_value; +vpi_register_cb; +vpi_register_systf; +vpi_remove_cb; +vpi_scan; +vpi_vprintf; +vpi_printf; + local: + *; +}; + diff --git a/src/translate/grt/main.adb b/src/translate/grt/main.adb new file mode 100644 index 0000000..5de3794 --- /dev/null +++ b/src/translate/grt/main.adb @@ -0,0 +1,32 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- 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 Ghdl_Main; + +function Main (Argc : Integer; Argv : System.Address) + return Integer +is +begin + return Ghdl_Main (Argc, Argv); +end Main; diff --git a/src/translate/grt/main.ads b/src/translate/grt/main.ads new file mode 100644 index 0000000..f7c4142 --- /dev/null +++ b/src/translate/grt/main.ads @@ -0,0 +1,34 @@ +-- GHDL Run Time (GRT) - C-like entry point. +-- 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. + +-- In the usual case of a standalone executable, this file defines the +-- standard entry point, ie the main() function. +-- +-- However, as explained in the manual, the user can use its own main() +-- function, and calls the ghdl entry point ghdl_main. +with System; + +function Main (Argc : Integer; Argv : System.Address) return Integer; +pragma Export (C, Main, "main"); |