diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cb7cf1a --- /dev/null +++ b/.gitignore @@ -0,0 +1,57 @@ +# Compiled source # +################### +*.com +*.class +*.dll +*.exe +*.o +*.so +*.cma + +# Packages # +############ +# it's better to unpack these files and commit the raw source +# git has its own built in compression methods +*.7z +*.dmg +*.gz +*.iso +*.jar +*.rar +*.tar +*.zip + +# Logs and databases # +###################### +*.log +*.sql +*.sqlite + +# OS generated files # +###################### +.DS_Store +.DS_Store? +._* +.Spotlight-V100 +.Trashes +ehthumbs.db +Thumbs.db + +#latex generated files# +####################### +*.pdf +*.blg +*.aux +*.bbl + +#Time-C generated files# +######################## +*.i +*.o +*.cil.c +*.dot + +#Time-C generated files# +######################## +ktcexe +_build/ diff --git a/.gitignore.swp b/.gitignore.swp new file mode 100644 index 0000000..2a445ff Binary files /dev/null and b/.gitignore.swp differ diff --git a/.myocamlbuild.ml.swp b/.myocamlbuild.ml.swp new file mode 100644 index 0000000..2d56623 Binary files /dev/null and b/.myocamlbuild.ml.swp differ diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..a8d1f76 --- /dev/null +++ b/Makefile @@ -0,0 +1,32 @@ +DIRS = src + +.PHONY: all + +# Init submodules if needed and make native version. +# The resulting executable can be found under /bin and /library (symlinks) +all: ktcutil ktcoption native + +# Compile native version. +ktcutil: + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) ktcutil.cma + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) ktcutil.cmxa + @rm -f bytes.ml + @cp _build/src/ktcutil.cma libs/. + @cp _build/src/ktcutil.cmxa libs/. + +ktcoption: + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) ktcoptions.cma + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) ktcoptions.cmxa + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) cilktc.cma + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) cilktc.cmxa + @rm -f bytes.ml + @cp _build/src/ktcoptions.cma libs/. + @cp _build/src/ktcoptions.cmxa libs/. + + + +native: + @ocamlbuild -no-hygiene -use-ocamlfind -package cil -Is $(DIRS) main.native + @rm -f main.native + @cd bin; cp ../_build/src/main.native ktcexe + diff --git a/bin/.demo1.c.swn b/bin/.demo1.c.swn new file mode 100644 index 0000000..bb39f81 Binary files /dev/null and b/bin/.demo1.c.swn differ diff --git a/bin/.hello.cil.c.swp b/bin/.hello.cil.c.swp new file mode 100644 index 0000000..71b0c6d Binary files /dev/null and b/bin/.hello.cil.c.swp differ diff --git a/bin/.sd.cil.c.swp b/bin/.sd.cil.c.swp new file mode 100644 index 0000000..e502120 Binary files /dev/null and b/bin/.sd.cil.c.swp differ diff --git a/bin/hey.dor b/bin/hey.dor new file mode 100644 index 0000000..e69de29 diff --git a/bin/ktc b/bin/ktc new file mode 100755 index 0000000..e47a1a2 --- /dev/null +++ b/bin/ktc @@ -0,0 +1,21 @@ +#!/usr/bin/perl +# +# The main driver for the Ktc system. +# + +use strict; + +use FindBin; +use lib "$FindBin::RealBin/../.."; +use lib "$FindBin::RealBin/../lib"; +use lib "$FindBin::RealBin/../cil/bin"; +use lib "$FindBin::RealBin/../cil/lib"; + +use App::Cilly::CilConfig; +use Ktc; + +$::ktchome = "$FindBin::RealBin/.."; + +Ktc->new(@ARGV)->doit(); + +exit(0); diff --git a/bin/log b/bin/log new file mode 100644 index 0000000..2fe23dd --- /dev/null +++ b/bin/log @@ -0,0 +1,17 @@ +Pred 1 -- 0 +Pred 2 -- 1 +Pred 3 -- 2 +Pred 4 -- 3 +Pred 5 -- 4 +Pred 7 -- 5 +Pred 7 -- 6 +Pred 6 -- 5 +Available for 0: {} +Available for 1: {a} +Available for sdelay: {a} +Available for 3: {a,b} +Available for fdelay: {a,b} +Available for 5: {a,b} +Available for callme: {a,b} +Available for 7: {a,b} + diff --git a/cilktc-lib/cilktc_lib.c b/cilktc-lib/cilktc_lib.c new file mode 100644 index 0000000..653a8ac --- /dev/null +++ b/cilktc-lib/cilktc_lib.c @@ -0,0 +1,310 @@ +#ifndef __MACH__ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +static __thread pid_t cached_tid = -1; +pid_t gettid() +{ + if (cached_tid == -1) { + cached_tid = (pid_t) syscall (SYS_gettid); + } + return cached_tid; +} + +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} + +#define CACHE_REFS_CTR 0 +#define CACHE_MISS_CTR 1 +static struct perf_event_attr peattrs[] = { + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_REFERENCES}, + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_MISSES}, +}; + +static __thread int perf_counter_fds[] = {-1, -1}; + +static inline int +sys_perf_event_open(struct perf_event_attr *attr, pid_t pid, int cpu, + int group_fd, unsigned long flags) +{ + attr->size = sizeof(*attr); + return syscall(__NR_perf_event_open, attr, pid, cpu, group_fd, flags); +} + +static void open_perf_counter(pid_t pid, int counter) +{ + if (perf_counter_fds[counter] < 0) { + int fd = -1; + struct perf_event_attr *attr = &peattrs[counter]; + + attr->inherit = 1; + fd = sys_perf_event_open(attr, pid, -1, -1, 0); + if (fd < 0) { + perror("sys_perf_event_open_failed"); + } + + perf_counter_fds[counter] = fd; + } + return; +} + +static uint64_t read_perf_counter(int *perffds, int counter) +{ + uint64_t val = 0; + size_t res; + + res = read(perffds[counter], &val, sizeof(uint64_t)); + if (res == -1) { + perror("read"); + } + + return val; +} + +static void close_perf_counter(int counter) +{ + if (perf_counter_fds[counter] > 0) { + close(perf_counter_fds[counter]); + perf_counter_fds[counter] = -1; + } + return; +} + +void perf_init(pid_t pid) +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + open_perf_counter(pid, i); + } + return; +} + +void perf_deinit() +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + close_perf_counter(i); + } + return; +} + +uint64_t perf_get_cache_refs() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_REFS_CTR); +} + +uint64_t perf_get_cache_miss() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_MISS_CTR); +} + +static inline uint64_t nsecs_of_timespec(struct timespec *ts) +{ + return (uint64_t)ts->tv_sec * 1000000000ULL + (uint64_t)ts->tv_nsec; +} + +uint64_t tut_get_time() +{ + struct timespec t; + clock_gettime(CLOCK_REALTIME, &t); + return nsecs_of_timespec(&t); +} + +/*START --- TIMED-C*/ + +long timespec_to_unit(struct timespec val, char* unit){ + + if(!strcmp(unit, "sec")){ + return(val.tv_sec + val.tv_nsec/1000000000); + } + if(!strcmp(unit, "ms")){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); + } + if(!strcmp(unit, "micro")){ + return(val.tv_sec*1000000 + val.tv_nsec/1000); + } + if(!strcmp(unit, "ns")){ + return(val.tv_sec*1000000000 + val.tv_nsec); + } + return 0; +} + +/* Computes the difference between two timespec values, returns (time1-time2)*/ +struct timespec diff_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + if((time1.tv_sec < time2.tv_sec) || + ((time1.tv_sec == time2.tv_sec) && + (time1.tv_nsec <= time2.tv_nsec))){ + result.tv_sec = result.tv_nsec = 0; + } + else{ + result.tv_sec = time1.tv_sec - time2.tv_sec; + if(time1.tv_nsec < time2.tv_nsec){ + result.tv_nsec = time1.tv_nsec + 1000000000 - time2.tv_nsec; + result.tv_sec--; + } + else{ + result.tv_nsec = time1.tv_nsec - time2.tv_nsec; + + } + } + return(result); +} + +/* Function to add two timespec values*/ +struct timespec add_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + result.tv_sec = time1.tv_sec + time2.tv_sec; + result.tv_nsec = time1.tv_nsec + time2.tv_nsec; + if(result.tv_nsec >= NANO){ + result.tv_sec++; + result.tv_nsec = result.tv_nsec-NANO; + + } + return(result); +} + +/** Compares two timespec value +Return Value : time1 < time2 -1 + time1 > time2 1 + time1 = time2 0 +**/ +int cmp_timespec(struct timespec time1, struct timespec time2){ + if(time1.tv_sec < time2.tv_sec){ + return(-1); + } + else if(time1.tv_sec > time2.tv_sec){ + return(1); + } + else if(time1.tv_nsec < time2.tv_nsec){ + return(-1); + } + else if(time1.tv_nsec > time2.tv_nsec){ + return(1); + } + else + return 0; +} + +/* Converts timespec value to user readable long (millisecond) value*/ +long convert_timespec_to_ms(struct timespec val){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); +} + +long convert_to_ms(long interval, char* unit){ + if(!strcmp(unit, "sec")){ + return(interval * 1000); + } + if(!strcmp(unit, "ms")){ + return(interval); + } + if(!strcmp(unit, "micro")){ + return(interval/1000); + } + if(!strcmp(unit, "ns")){ + return(interval/1000000); + } + +} + +/*Converts user specified interval from long value to timespec value + for computation in C*/ +struct timespec convert_to_timespec(long interval, char* unit){ + struct timespec temp; + if(!strcmp(unit, "sec")){ + temp.tv_sec = interval; + temp.tv_nsec = 0; + + } + if(!strcmp(unit, "ms")){ + temp.tv_sec = interval/MILLI; + temp.tv_nsec = (interval % MILLI)*(MILLI_TO_NANO); + } + if(!strcmp(unit, "micro")){ + temp.tv_sec = interval/MICRO; + temp.tv_nsec = (interval % MICRO)*(MICRO_TO_NANO); + } + if(!strcmp(unit, "ns")){ + temp.tv_sec = interval/NANO; + temp.tv_nsec = (interval % NANO); + } + return temp; +} + +#else + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include + +pid_t gettid() +{ + return (pid_t) syscall (SYS_gettid); +} + +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} + +void perf_init(pid_t pid) {} +void perf_deinit() {} + +uint64_t perf_get_cache_refs() +{ + return (uint64_t)0; +} + +uint64_t perf_get_cache_miss() +{ + return (uint64_t)0; +} + +uint64_t tut_get_time() +{ + uint64_t t; + static mach_timebase_info_data_t tinfo; + + t = mach_absolute_time(); + if (tinfo.denom == 0) { + mach_timebase_info(&tinfo); + } + + return t * tinfo.numer / tinfo.denom; +} +#endif diff --git a/cilktc-lib/sdelay.c b/cilktc-lib/sdelay.c new file mode 100644 index 0000000..663fad6 --- /dev/null +++ b/cilktc-lib/sdelay.c @@ -0,0 +1,47 @@ + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include + +sigset_t oldmask, newmask; + + +long ktc_sdelay_init(char const *f, int l, int intrval, char* unit, struct timespec* start_time){ + struct timespec end_time, elapsed_time, wait_time, interval_time; + interval_time = convert_to_timespec(intrval, unit); + (void) clock_gettime(CLOCK_REALTIME, &end_time); + elapsed_time = diff_timespec(end_time, (*start_time)); + if(cmp_timespec(interval_time, elapsed_time) == 1){ + wait_time = add_timespec((*start_time), interval_time); + clock_nanosleep(CLOCK_REALTIME, TIMER_ABSTIME, &wait_time, NULL); + (void) clock_gettime(CLOCK_REALTIME, start_time); + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == 0){ + (void) clock_gettime(CLOCK_REALTIME, start_time); + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == -1){ + wait_time = add_timespec((*start_time), interval_time); + elapsed_time = diff_timespec(end_time, wait_time); + (void) clock_gettime(CLOCK_REALTIME, start_time); + return (timespec_to_unit(elapsed_time, unit)); + } + /* printf("init:\n"); + sigfillset(&newmask); + sigprocmask(SIG_SETMASK, &newmask, &oldmask); + (void) clock_gettime(CLOCK_REALTIME, &start_time); + return;*/ + return 0; +} + +int ktc_sdelay_end(char const *f, int l, int intrval, char* unit) +{ + return 0; +} diff --git a/cilktc-lib/src/cilktc_lib.c b/cilktc-lib/src/cilktc_lib.c new file mode 100644 index 0000000..23ec0eb --- /dev/null +++ b/cilktc-lib/src/cilktc_lib.c @@ -0,0 +1,312 @@ +#ifndef __MACH__ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* +static __thread pid_t cached_tid = -1; +pid_t gettid() +{ + if (cached_tid == -1) { + cached_tid = (pid_t) syscall (SYS_gettid); + } + return cached_tid; +} + +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} + +#define CACHE_REFS_CTR 0 +#define CACHE_MISS_CTR 1 +static struct perf_event_attr peattrs[] = { + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_REFERENCES}, + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_MISSES}, +}; + +static __thread int perf_counter_fds[] = {-1, -1}; + +static inline int +sys_perf_event_open(struct perf_event_attr *attr, pid_t pid, int cpu, + int group_fd, unsigned long flags) +{ + attr->size = sizeof(*attr); + return syscall(__NR_perf_event_open, attr, pid, cpu, group_fd, flags); +} + +static void open_perf_counter(pid_t pid, int counter) +{ + if (perf_counter_fds[counter] < 0) { + int fd = -1; + struct perf_event_attr *attr = &peattrs[counter]; + + attr->inherit = 1; + fd = sys_perf_event_open(attr, pid, -1, -1, 0); + if (fd < 0) { + perror("sys_perf_event_open_failed"); + } + + perf_counter_fds[counter] = fd; + } + return; +} + +static uint64_t read_perf_counter(int *perffds, int counter) +{ + uint64_t val = 0; + size_t res; + + res = read(perffds[counter], &val, sizeof(uint64_t)); + if (res == -1) { + perror("read"); + } + + return val; +} + +static void close_perf_counter(int counter) +{ + if (perf_counter_fds[counter] > 0) { + close(perf_counter_fds[counter]); + perf_counter_fds[counter] = -1; + } + return; +} + +void perf_init(pid_t pid) +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + open_perf_counter(pid, i); + } + return; +} + +void perf_deinit() +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + close_perf_counter(i); + } + return; +} + +uint64_t perf_get_cache_refs() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_REFS_CTR); +} + +uint64_t perf_get_cache_miss() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_MISS_CTR); +} + +static inline uint64_t nsecs_of_timespec(struct timespec *ts) +{ + return (uint64_t)ts->tv_sec * 1000000000ULL + (uint64_t)ts->tv_nsec; +} + +uint64_t tut_get_time() +{ + struct timespec t; + clock_gettime(CLOCK_REALTIME, &t); + return nsecs_of_timespec(&t); +} +*/ +/*START --- TIMED-C*/ + +long timespec_to_unit(struct timespec val, char* unit){ + + if(!strcmp(unit, "sec")){ + return(val.tv_sec + val.tv_nsec/1000000000); + } + if(!strcmp(unit, "ms")){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); + } + if(!strcmp(unit, "micro")){ + return(val.tv_sec*1000000 + val.tv_nsec/1000); + } + if(!strcmp(unit, "ns")){ + return(val.tv_sec*1000000000 + val.tv_nsec); + } + return 0; +} + +/* Computes the difference between two timespec values, returns (time1-time2)*/ +struct timespec diff_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + if((time1.tv_sec < time2.tv_sec) || + ((time1.tv_sec == time2.tv_sec) && + (time1.tv_nsec <= time2.tv_nsec))){ + result.tv_sec = result.tv_nsec = 0; + } + else{ + result.tv_sec = time1.tv_sec - time2.tv_sec; + if(time1.tv_nsec < time2.tv_nsec){ + result.tv_nsec = time1.tv_nsec + 1000000000 - time2.tv_nsec; + result.tv_sec--; + } + else{ + result.tv_nsec = time1.tv_nsec - time2.tv_nsec; + + } + } + return(result); +} + +/* Function to add two timespec values*/ +struct timespec add_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + result.tv_sec = time1.tv_sec + time2.tv_sec; + result.tv_nsec = time1.tv_nsec + time2.tv_nsec; + if(result.tv_nsec >= NANO){ + result.tv_sec++; + result.tv_nsec = result.tv_nsec-NANO; + + } + return(result); +} + +/** Compares two timespec value +Return Value : time1 < time2 -1 + time1 > time2 1 + time1 = time2 0 +**/ +int cmp_timespec(struct timespec time1, struct timespec time2){ + if(time1.tv_sec < time2.tv_sec){ + return(-1); + } + else if(time1.tv_sec > time2.tv_sec){ + return(1); + } + else if(time1.tv_nsec < time2.tv_nsec){ + return(-1); + } + else if(time1.tv_nsec > time2.tv_nsec){ + return(1); + } + else + return 0; +} + +/* Converts timespec value to user readable long (millisecond) value*/ +long convert_timespec_to_ms(struct timespec val){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); +} + +long convert_to_ms(long interval, char* unit){ + if(!strcmp(unit, "sec")){ + return(interval * 1000); + } + if(!strcmp(unit, "ms")){ + return(interval); + } + if(!strcmp(unit, "micro")){ + return(interval/1000); + } + if(!strcmp(unit, "ns")){ + return(interval/1000000); + } + +} + +/*Converts user specified interval from long value to timespec value + for computation in C*/ +struct timespec convert_to_timespec(long interval, char* unit){ + struct timespec temp; + if(!strcmp(unit, "sec")){ + temp.tv_sec = interval; + temp.tv_nsec = 0; + + } + if(!strcmp(unit, "ms")){ + temp.tv_sec = interval/MILLI; + temp.tv_nsec = (interval % MILLI)*(MILLI_TO_NANO); + } + if(!strcmp(unit, "micro")){ + temp.tv_sec = interval/MICRO; + temp.tv_nsec = (interval % MICRO)*(MICRO_TO_NANO); + } + if(!strcmp(unit, "ns")){ + temp.tv_sec = interval/NANO; + temp.tv_nsec = (interval % NANO); + } + return temp; +} + +#else + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include + +pid_t gettid() +{ + return (pid_t) syscall (SYS_gettid); +} + +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} + +void perf_init(pid_t pid) {} +void perf_deinit() {} + +uint64_t perf_get_cache_refs() +{ + return (uint64_t)0; +} + +uint64_t perf_get_cache_miss() +{ + return (uint64_t)0; +} + +uint64_t tut_get_time() +{ + uint64_t t; + static mach_timebase_info_data_t tinfo; + + t = mach_absolute_time(); + if (tinfo.denom == 0) { + mach_timebase_info(&tinfo); + } + + return t * tinfo.numer / tinfo.denom; +} +#endif diff --git a/cilktc-lib/src/hey b/cilktc-lib/src/hey new file mode 100755 index 0000000..0468fd1 Binary files /dev/null and b/cilktc-lib/src/hey differ diff --git a/cilktc-lib/src/libktc.a b/cilktc-lib/src/libktc.a new file mode 100644 index 0000000..75a310f Binary files /dev/null and b/cilktc-lib/src/libktc.a differ diff --git a/cilktc-lib/src/sdelay.c b/cilktc-lib/src/sdelay.c new file mode 100644 index 0000000..3867a32 --- /dev/null +++ b/cilktc-lib/src/sdelay.c @@ -0,0 +1,144 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +sigset_t oldmask, newmask; + + +long ktc_sdelay_init(int intrval, char* unit, struct timespec* start_time){ + struct timespec end_time, elapsed_time, wait_time, interval_time; + interval_time = convert_to_timespec(intrval, unit); + (void) clock_gettime(CLOCK_REALTIME, &end_time); + elapsed_time = diff_timespec(end_time, (*start_time)); + if(cmp_timespec(interval_time, elapsed_time) == 1){ + wait_time = add_timespec((*start_time), interval_time); + clock_nanosleep(CLOCK_REALTIME, TIMER_ABSTIME, &wait_time, NULL); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == 0){ + wait_time = add_timespec((*start_time), interval_time); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == -1){ + wait_time = add_timespec((*start_time), interval_time); + elapsed_time = diff_timespec(end_time, wait_time); /*elapsed_time here is the obershot*/ + *start_time = add_timespec(wait_time, elapsed_time); + return (timespec_to_unit(elapsed_time, unit)); + } + /* printf("init:\n"); + sigfillset(&newmask); + sigprocmask(SIG_SETMASK, &newmask, &oldmask); + (void) clock_gettime(CLOCK_REALTIME, &start_time); + return;*/ + return 0; +} + +int ktc_start_time_init(struct timespec* start_time) +{ + (void) clock_gettime(CLOCK_REALTIME, start_time); + return 0; +} +/* +void main(){ + struct timespec start_time; + char* f ="hey"; + int l = 100; + int intrvl = 12; + char* unit = "NULL"; + ktc_sdelay_init(f,l,intrvl,unit, &start_time); +} +*/ + +void timer_signal_handler(int sig, siginfo_t *extra, void *cruft){ + struct tp_struct* tp ; + tp = (struct tp_struct*) extra->si_value.sival_ptr; + printf("Timer Handle\n"); + if(tp->waiting != 1){ + tp->waiting = 0; + siglongjmp(tp->env, 1); + } +} + +void ktc_create_timer(timer_t* ktctimer, struct tp_struct* tp){ + struct sigaction sa; + struct sigevent timer_event; + sigfillset(&sa.sa_mask); + sa.sa_flags = SA_SIGINFO; + sa.sa_sigaction = timer_signal_handler; + + if(sigaction(SIGRTMIN, &sa, NULL) < 0){ + perror("sigaction"); + exit(0); + } + tp->waiting = 0; + tp->tmr = ktctimer; + timer_event.sigev_notify = SIGEV_SIGNAL; + timer_event.sigev_signo = SIGRTMIN; + timer_event.sigev_value.sival_ptr = (void*) tp; + + if(timer_create(CLOCK_REALTIME, &timer_event, ktctimer) < 0){ + perror("timer_create"); + exit(0); + } + + +} + +long ktc_fdelay_init(int interval, char* unit, struct timespec* start_time) { + sigset_t allsigs; + sigfillset(&allsigs); + sigdelset(&allsigs, SIGRTMIN); + sigsuspend(&allsigs); + +} + +int ktc_fdelay_start_timer(int interval, char* unit, timer_t ktctimer, struct timespec start_time){ + struct timespec interval_timespec; + struct itimerspec i; + + interval_timespec = convert_to_timespec(3, "ms"); + i.it_value = add_timespec(start_time, interval_timespec); + i.it_interval.tv_sec = 0; + i.it_interval.tv_nsec = 0; + if(timer_settime(ktctimer, TIMER_ABSTIME, &i, NULL) < 0){ + perror("timer_setitimer"); + exit(0); + } + +} + +/* +void main(){ + struct tp_struct tp; + int ret_jmp; + timer_t ktctimer; + struct timespec start_time, interval_timespec; + struct itimerspec i; + create_timer(&ktctimer, &tp); + + ret_jmp = __sigsetjmp(tp.env, 1); + interval_timespec = convert_to_timespec(3, "ms"); + ktc_start_time_init(&start_time); + start_timer_fdelay(3, "ms", ktctimer, start_time); + i.it_value = add_timespec(start_time, interval_timespec); + i.it_interval.tv_sec = 0; + i.it_interval.tv_nsec = 0; + printf("jgd0"); + if(timer_settime(ktctimer, TIMER_ABSTIME, &i, NULL) < 0){ + perror("timer_setitimer"); + exit(0); + } + printf("sleeping\n"); + sleep(1); + tp.waiting = 1; + ktc_fdelay_init(3, "ms", &start_time); +}*/ diff --git a/cilktc-lib/src/sdelay1.c b/cilktc-lib/src/sdelay1.c new file mode 100644 index 0000000..591e7bd --- /dev/null +++ b/cilktc-lib/src/sdelay1.c @@ -0,0 +1,89 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +sigset_t oldmask, newmask; + + +long ktc_sdelay_init(int intrval, char* unit, struct timespec* start_time){ + struct timespec end_time, elapsed_time, wait_time, interval_time; + interval_time = convert_to_timespec(intrval, unit); + (void) clock_gettime(CLOCK_REALTIME, &end_time); + elapsed_time = diff_timespec(end_time, (*start_time)); + if(cmp_timespec(interval_time, elapsed_time) == 1){ + wait_time = add_timespec((*start_time), interval_time); + clock_nanosleep(CLOCK_REALTIME, TIMER_ABSTIME, &wait_time, NULL); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == 0){ + wait_time = add_timespec((*start_time), interval_time); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == -1){ + wait_time = add_timespec((*start_time), interval_time); + elapsed_time = diff_timespec(end_time, wait_time); /*elapsed_time here is the obershot*/ + *start_time = add_timespec(wait_time, elapsed_time); + return (timespec_to_unit(elapsed_time, unit)); + } + /* printf("init:\n"); + sigfillset(&newmask); + sigprocmask(SIG_SETMASK, &newmask, &oldmask); + (void) clock_gettime(CLOCK_REALTIME, &start_time); + return;*/ + return 0; +} + +int ktc_start_time_init(struct timespec* start_time) +{ + (void) clock_gettime(CLOCK_REALTIME, start_time); + return 0; +} +/* +void main(){ + struct timespec start_time; + char* f ="hey"; + int l = 100; + int intrvl = 12; + char* unit = "NULL"; + ktc_sdelay_init(f,l,intrvl,unit, &start_time); +} +*/ + +void timer_signal_handler(int sig, siginfo_t *extra, void *cruft){ + +} + +void create_timer(timer_t* ktctimer){ + struct sigaction sa; + struct sigevent timer_event; + sigfillset(&sa.sa_mask); + sa.sa_flags = SA_SIGINFO; + sa.sa_sigaction = timer_signal_handler; + + if(sigaction(SIGRTMIN, &sa, NULL) < 0){ + perror("sigaction"); + exit(0); + } + + timer_event.sigev_notify = SIGEV_SIGNAL; + timer_event.sigev_signo = SIGRTMIN; + timer_event.sigev_value.sival_ptr = (void*) ktctimer; + + if(timer_create(CLOCK_REALTIME, &timer_event, ktctimer) < 0){ + perror("timer_create"); + exit(0); + } + + +} + +long ktc_fdelay_init(int interval, char* unit, struct timespec* start_time) { +} diff --git a/cilktc-lib/src/test b/cilktc-lib/src/test new file mode 100755 index 0000000..bf08646 Binary files /dev/null and b/cilktc-lib/src/test differ diff --git a/cilktc-lib/src/test_timer.c b/cilktc-lib/src/test_timer.c new file mode 100644 index 0000000..d142e5a --- /dev/null +++ b/cilktc-lib/src/test_timer.c @@ -0,0 +1,144 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +sigset_t oldmask, newmask; + + +long ktc_sdelay_init(int intrval, char* unit, struct timespec* start_time){ + struct timespec end_time, elapsed_time, wait_time, interval_time; + interval_time = convert_to_timespec(intrval, unit); + (void) clock_gettime(CLOCK_REALTIME, &end_time); + elapsed_time = diff_timespec(end_time, (*start_time)); + if(cmp_timespec(interval_time, elapsed_time) == 1){ + wait_time = add_timespec((*start_time), interval_time); + clock_nanosleep(CLOCK_REALTIME, TIMER_ABSTIME, &wait_time, NULL); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == 0){ + wait_time = add_timespec((*start_time), interval_time); + *start_time = wait_time; + return 0; + } + if(cmp_timespec(interval_time, elapsed_time) == -1){ + wait_time = add_timespec((*start_time), interval_time); + elapsed_time = diff_timespec(end_time, wait_time); /*elapsed_time here is the obershot*/ + *start_time = add_timespec(wait_time, elapsed_time); + return (timespec_to_unit(elapsed_time, unit)); + } + /* printf("init:\n"); + sigfillset(&newmask); + sigprocmask(SIG_SETMASK, &newmask, &oldmask); + (void) clock_gettime(CLOCK_REALTIME, &start_time); + return;*/ + return 0; +} + +int ktc_start_time_init(struct timespec* start_time) +{ + (void) clock_gettime(CLOCK_REALTIME, start_time); + return 0; +} +/* +void main(){ + struct timespec start_time; + char* f ="hey"; + int l = 100; + int intrvl = 12; + char* unit = "NULL"; + ktc_sdelay_init(f,l,intrvl,unit, &start_time); +} +*/ + +void timer_signal_handler(int sig, siginfo_t *extra, void *cruft){ + struct tp_struct* tp ; + tp = (struct tp_struct*) extra->si_value.sival_ptr; + printf("Timer Handle\n"); + if(tp->waiting != 1){ + tp->waiting = 0; + siglongjmp(tp->env, 1); + } +} + +void create_timer(timer_t* ktctimer, struct tp_struct* tp){ + struct sigaction sa; + struct sigevent timer_event; + sigfillset(&sa.sa_mask); + sa.sa_flags = SA_SIGINFO; + sa.sa_sigaction = timer_signal_handler; + + if(sigaction(SIGRTMIN, &sa, NULL) < 0){ + perror("sigaction"); + exit(0); + } + tp->waiting = 0; + tp->tmr = ktctimer; + timer_event.sigev_notify = SIGEV_SIGNAL; + timer_event.sigev_signo = SIGRTMIN; + timer_event.sigev_value.sival_ptr = (void*) tp; + + if(timer_create(CLOCK_REALTIME, &timer_event, ktctimer) < 0){ + perror("timer_create"); + exit(0); + } + + +} + +long ktc_fdelay_init(int interval, char* unit, struct timespec* start_time) { + sigset_t allsigs; + sigfillset(&allsigs); + sigdelset(&allsigs, SIGRTMIN); + sigsuspend(&allsigs); + +} + +int start_timer_fdelay(int interval, char* unit, timer_t ktctimer, struct timespec start_time){ + struct timespec interval_timespec; + struct itimerspec i; + + interval_timespec = convert_to_timespec(3, "ms"); + i.it_value = add_timespec(start_time, interval_timespec); + i.it_interval.tv_sec = 0; + i.it_interval.tv_nsec = 0; + if(timer_settime(ktctimer, TIMER_ABSTIME, &i, NULL) < 0){ + perror("timer_setitimer"); + exit(0); + } + +} + +/* +void main(){ + struct tp_struct tp; + int ret_jmp; + timer_t ktctimer; + struct timespec start_time, interval_timespec; + struct itimerspec i; + create_timer(&ktctimer, &tp); + + ret_jmp = __sigsetjmp(tp.env, 1); + interval_timespec = convert_to_timespec(3, "ms"); + ktc_start_time_init(&start_time); + start_timer_fdelay(3, "ms", ktctimer, start_time); + i.it_value = add_timespec(start_time, interval_timespec); + i.it_interval.tv_sec = 0; + i.it_interval.tv_nsec = 0; + printf("jgd0"); + if(timer_settime(ktctimer, TIMER_ABSTIME, &i, NULL) < 0){ + perror("timer_setitimer"); + exit(0); + } + printf("sleeping\n"); + sleep(1); + tp.waiting = 1; + ktc_fdelay_init(3, "ms", &start_time); +}*/ diff --git a/include/.cilktc.h.swp b/include/.cilktc.h.swp new file mode 100644 index 0000000..5ce46e1 Binary files /dev/null and b/include/.cilktc.h.swp differ diff --git a/include/cilktc.h b/include/cilktc.h new file mode 100644 index 0000000..63a7a69 --- /dev/null +++ b/include/cilktc.h @@ -0,0 +1,166 @@ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define SEC_TO_NANO 1000000000 +#define MILLI_TO_NANO 1000000 +#define MICRO_TO_NANO 1000 +#define MILLI 1000 +#define MICRO 1000000 +#define NANO 1000000000 + +#define CONSTRUCTOR __attribute__((constructor)) + + +#define ExactRGB(r,g,b) __attribute__((ExactRGB((r),(g),(b)))) +#define LowerRGB(r,g,b) __attribute__((LowerRGB((r),(g),(b)))) +#define UpperRGB(r,g,b) __attribute__((UpperRGB((r),(g),(b)))) + +#define AddRGB(x,r,g,b) (typeof(x) ExactRGB(r,g,b))x + + +#define red __attribute__((red)) +#define green __attribute__((green)) +#define blue __attribute__((blue)) +#define AddColor(c,x) (typeof(x) c)x + + +#define cache_report if((void *__attribute__((cache_report)))0) + +//#define sdelay(c) printf("%d", c) + +#define invariant(c,i,...) __blockattribute__((invariant((c),(i),__VA_ARGS__))) +#define post(c) __attribute__((post((c)))) +#define pre(c) __attribute__((pre((c)))) + +void *checked_dlsym(void *handle, const char *sym); +pid_t gettid(); + +void perf_init(pid_t pid); +uint64_t perf_get_cache_refs(); +uint64_t perf_get_cache_miss(); +void perf_deinit(); +uint64_t tut_get_time(); + +struct timespec* timepecptr; +timer_t ftimer; +struct timespec diff_timespec(struct timespec, struct timespec); +struct timespec add_timespec(struct timespec, struct timespec); +int cmp_timespec(struct timespec, struct timespec); +long convert_timespec_to_ms(struct timespec); +long convert_to_ms(long, char*); +struct timespec convert_to_timespec(long, char*); +long timespec_to_unit(struct timespec val, char* unit); + +void toggle_lock_tracking(); + +struct tp_struct{ + int waiting; + jmp_buf env; + timer_t* tmr; +}; +struct tp_struct tp_struct_data; +void ktc_create_timer(timer_t* ktctimer, struct tp_struct* tp); +extern int ktc_start_time_init(struct timespec* start_time) ; +extern long ktc_sdelay_init(int intrval, char* unit, struct timespec* start_time ) ; +extern long ktc_fdelay_init(int intrval, char* unit, struct timespec* start_time ) ; +sigjmp_buf buf_struct; +#include +size_t s; +struct option o; +/* +static inline int setjmpdummy(){ + sigsetjmp(buf_struct, 1); +} +*/ + +//#pragma cilnoremove("getoptdummy") +static inline int getoptdummy() +{ + int i; + optarg = NULL; + sscanf(NULL,"%d",&i); + return getopt_long(0, NULL, NULL, NULL, NULL); +} + +#define ARG_HAS_OPT 1 + +#define argument(argtype, argname, ...) \ +argtype argname; \ +int argname##got; \ +struct ciltut_##argname { \ + char *short_form; \ + char *help_text; \ + char *format; \ + argtype def; \ + void *requires; \ + int has_opt; \ +} __attribute__((ciltutarg, ##__VA_ARGS__)) _ciltut_##argname = + +#define arg_assert(e) (void *__attribute__((ciltut_assert((e)))))0 + + +#define autotest __attribute__((autotest)) +#define instrument __attribute__((instrument)) +#define input __attribute__((input)) +#define inputarr(s) __attribute__((inputarr(s))) +#define inputnt __attribute__((inputnt)) + +void assign(uint64_t lhs, uint64_t op, int opk, uint64_t opv); +void assgn_bop(uint64_t lhs, uint64_t lhsv, int bop, + uint64_t op1, int op1k, uint64_t op1v, + uint64_t op2, int op2k, uint64_t op2v); +void assgn_uop(uint64_t lhs, uint64_t lhsv, int uop, + uint64_t op, int opk, uint64_t opv); + +void cond(int cid, int r, uint64_t op, int opk, uint64_t opv); +void cond_bop(int cid, int bop, int r, + uint64_t op1, int op1k, uint64_t op1v, + uint64_t op2, int op2k, uint64_t op2v); +void cond_uop(int cid, int uop, int r, + uint64_t op, int opk, uint64_t opv); + +void register_input(char *name, uint64_t addr, int bits); +void register_arr_input(char *name, uint64_t start, int sz, int cnt); +void register_nt_input(char *name, char *start); +//int ktc_sdelay_end(char const *f , int l , int intrval , char *unit ) ; +//void ktc_sdelay_init(char const *f , int l ) ; +int ktc_fdelay_start_timer(int interval, char* unit, timer_t ktctimer, struct timespec start_time); +#pragma cilnoremove("ktc_start_time_init") +#pragma cilnoremove("ktc_sdelay_init") +#pragma cilnoremove("ktc_fdelay_init") +#pragma cilnoremove("timepecptr") +#pragma cilnoremove("env") +#pragma cilnoremove("ftimer") +#pragma cilnoremove("ktc_create_timer") +#pragma cilnoremove("tp_struct_data") +#pragma cilnoremove("__sigsetjmp") +#pragma cilnoremove("ktc_fdelay_start_timer") +extern int autotest_finished; +//extern int ktc_sdelay_end(char const *f , int l , int intrval , char *unit ) ; +//extern long ktc_sdelay_init(char const *f , int l, int intrval, char* unit, struct timespec* start_time ) ; +void gen_new_input(); + +void val_push(uint64_t v); +uint64_t val_pop(char *name); +void pop_array(char *name, char *base, int cnt, int sz); +void pop_nt(char * name, char *base); + +void return_push(uint64_t p, uint64_t v); +void return_pop(uint64_t p, uint64_t v); + +void autotest_reset(); + +//int ktc_sdelay_end(char const *f , int l , int intrval , char *unit ) ; +//void ktc_sdelay_init(char const *f , int l ) ; + + + diff --git a/lib/.Ktc.pm.swp b/lib/.Ktc.pm.swp new file mode 100644 index 0000000..4a977a0 Binary files /dev/null and b/lib/.Ktc.pm.swp differ diff --git a/lib/Ktc.pm b/lib/Ktc.pm new file mode 100755 index 0000000..c6fdcc0 --- /dev/null +++ b/lib/Ktc.pm @@ -0,0 +1,270 @@ + +# This package is used from an environment when CilConfig.pm has been loaded +package Ktc; +use strict; + +$::version_major = 1; +$::version_minor = 0; +$::version_sub = 0; + +use App::Cilly; + +# NOTE: If perl chokes, complaining about 'our', or +# "Array found where operator expected", it's because +# you need perl version 5.6.0 or later. +our @ISA = qw(App::Cilly); + +sub new { + my ($proto, @args) = @_; + my $class = ref($proto) || $proto; + + # Select the directory containing Ciltut's executables. We look in + # both places in order to accomodate the build and distribution + # directory layouts. + my $bin; + my $lib; + if (-x "$::ktchome/obj/$::archos/ktcexe") { + $bin = "$::ktchome/obj/$::archos"; + $lib = "$::ktchome/obj/$::archos"; + } elsif (-x "$::ktchome/bin/ktcexe") { + $bin = "$::ktchome/bin"; + $lib = "$::ktchome/lib"; + } else { + die "Couldn't find directory containing ktc executables.\n" . + "Please ensure that ktc is compiled and installed properly.\n"; + } + + # Select the most recent executable + my $mtime_asm = int((stat("$bin/ktcexe"))[9]); + my $mtime_byte = int((stat("$bin/ktcexe"))[9]); + my $use_debug = + grep(/--bytecode/, @args) || + grep(/--ocamldebug/, @args) || + ($mtime_asm < $mtime_byte); + if ($use_debug) { + $ENV{"OCAMLRUNPARAM"} = "b" . $ENV{"OCAMLRUNPARAM"}; # Print back trace + } + + # Save choice in global vars for printHelp (can be called from Cilly::new) + $Ktc::compiler = "$bin/ktcexe" ; + + my $self = Ktc->App::Cilly::new(@args); + + # New variables for Ktc + $self->{COMPILER} = $Ktc::compiler; + $self->{LIBBASE} = $lib; + + $self->{DARWIN} = `uname` =~ /Darwin/; + + push @{$self->{CPP}}, $self->{INCARG} . $::ktchome . "/include"; + my $v = $::version_major * 1000 + $::version_minor * 100 + $::version_sub; + push @{$self->{CPP}}, $self->{DEFARG} . (sprintf "__KTC__=%d", $v); + + # Override Cilly's default + $self->{SEPARATE} = 1; + + + $self->{CONCOLICLIB} = "$lib/libconcolic_callbacks.$self->{LIBEXT}"; + + bless $self, $class; +} + +sub processArguments { + my ($self) = @_; + my @args = @{$self->{ARGV}}; + my $lib = $self->{LIBBASE}; + + # Scan and process the arguments + $self->setDefaultArguments; + $self->collectArgumentList(@args); + + push @{$self->{KTCLIBS}}, "$lib/libktc.$self->{LIBEXT}"; + + return $self; +} + +sub setDefaultArguments { + my ($self) = @_; + $self->{TRACE_COMMANDS} = 0; + push @{$self->{CILARGS}}, "--home", $::ktchome; + return $self->SUPER::setDefaultArguments; +} + +sub collectOneArgument { + my ($self, $arg, $pargs) = @_; + my $res = 1; + if ($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { + # do nothing + } elsif ($arg eq "--help" || $arg eq "-help") { + $self->printVersion(); + $self->printHelp(); + exit 0; + } elsif ($arg eq "--version" || $arg eq "-version") { + $self->printVersion(); + exit 0; + } elsif ($arg eq "--trace") { + $self->{TRACE_COMMANDS} = 1; + } elsif ($arg eq "--bytecode") { + $self->{NATIVECAML} = 0; + } elsif ($arg =~ m|--save-temps=(.+)$|) { + if (!-d $1) { + die "Cannot find directory $1"; + } + $self->{SAVE_TEMPS} = $1; + } elsif ($arg eq '--save-temps') { + $self->{SAVE_TEMPS} = '.'; + } elsif ($arg =~ m|--includedir=(.+)$|) { + push @{$self->{INCLUDEDIR}}, $1; + } elsif ($arg =~ m|^--out=(\S+)$|) { + # Intercept the --out argument + $self->{CILLY_OUT} = $1; + push @{$self->{CILARGS}}, "--out", $1; + } elsif ($arg eq '--merge') { + $self->{SEPARATE} = 0; + } elsif ($arg =~ m|^--|) { + # All other arguments starting with -- are passed to CIL + # Split the == + if ($arg =~ m|^(--\S+)=(.+)$|) { + push @{$self->{CILARGS}}, $1, $2; + } else { + push @{$self->{CILARGS}}, $arg; + } + } else { + # We fail! + $res = 0; + } + return $res; +} + +sub preprocess_before_cil { + my($self, $src, $dest, $ppargs) = @_; + my @args = @{$ppargs}; + unshift @args, $self->{INCARG} . $::ktchome . "/include"; + return $self->SUPER::preprocess_before_cil($src, $dest, \@args); +} + + +## We do not preprocess after CIL, to save time and files +sub preprocessAfterOutputFile { + my ($self, $src) = @_; + return $src; # Do not preprocess after CIL +} + +sub preprocess_after_cil { + my ($self, $src, $dest, $ppargs) = @_; + if($src ne $dest) { die "I thought we are not preprocessing after CIL";} + return $dest; +} + +sub compile_cil { + my ($self, $src, $dest, $ppargs, $ccargs) = @_; + my @args = @{$ppargs}; + my @newargs; + my $i; + + # Filter out -include options + for ($i = 0; $i <= $#args; $i++) { + $_ = $args[$i]; + if (/^-include/) { + $i++; + } + else { + push @newargs, $_; + } + } + push @newargs, "$self->{INCARG}$::ktchome/include"; + return $self->SUPER::compile_cil($src, $dest, \@newargs, $ccargs); +} + + +sub link_after_cil { + my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + my @srcs = @{$psrcs}; + my @libs = @{$ldargs}; + my @cargs = @{$ccargs}; + if ($self->{DARWIN}) { + push @libs, "-Wl,-multiply_defined", "-Wl,suppress"; + } + if (scalar @srcs == 0) { + print STDERR "ktc: no input files\n"; + return 0; + } else { + if ($self->{TUT15} == 1) { + my $ocy = `ocamlfind query ocamlyices`; + chomp($ocy); + push @libs, "-L$::ktchome/lib", "-L/usr/lib/ocaml", "-L$ocy", + "-Wl,-rpath=$::ktchome/lib", + "-Wl,--start-group", + "-lcamlrun", + "-lktc", + "-lunix", + "-lnums", + "-Wl,--end-group", + "-lcurses", + "-locamlyices", + "-lstdc++", + "-lm", + "/usr/local/lib/libyices.a"; + } + else { + push @libs, @{$self->{KTCLIBS}}; + } + if ($self->{DARWIN}) { + push @libs, "-ldl"; + } + else { + push @libs, "-ldl", "-lrt"; + } + return $self->SUPER::link_after_cil(\@srcs, $dest, $ppargs, + \@cargs, \@libs); + } +} + +sub linktolib { + my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + my @srcs = @{$psrcs}; + my @libs = @{$ldargs}; + if (scalar @srcs == 0) { + print STDERR "ktc: no input files\n"; + return 0; + } else { + push @libs, @{$self->{KTCLIBS}}; + return $self->SUPER::linktolib(\@srcs, $dest, $ppargs, + $ccargs, $ldargs); + } +} + +sub CillyCommand { + my ($self, $ppsrc, $dest) = @_; + + my @cmd = ($self->{COMPILER}); + my $aftercil = $self->cilOutputFile($dest, 'cil.c'); + return ($aftercil, @cmd, '--out', $aftercil); +} + +sub printVersion { + printf "ktc: %d.%d.%d\n", $::version_major, $::version_minor, $::version_sub; +} + +sub printHelp { + my ($self) = @_; + my @cmd = ($self->{COMPILER}, '-help'); + print <... + +Front end: + + --trace Print commands invoked by the front end. + --save-temps[=] Save intermediate files (target directory optional). + --version Print version number and exit. + --includedir Add the specified directory to the beginning of + the include path. + --gcc Use the specified executable instead of gcc as the + final C compiler (see also the --envmachine option) + +EOF + $self->runShell(@cmd); +} + +1; diff --git a/lib/ktc_libc.c b/lib/ktc_libc.c new file mode 100644 index 0000000..d2623bd --- /dev/null +++ b/lib/ktc_libc.c @@ -0,0 +1,317 @@ +#ifndef __MACH__ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +static __thread pid_t cached_tid = -1; +pid_t gettid() +{ + if (cached_tid == -1) { + cached_tid = (pid_t) syscall (SYS_gettid); + } + return cached_tid; +} +/* +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} +*/ +#define SEC_TO_NANO 1000000000 +#define MILLI_TO_NANO 1000000 +#define MICRO_TO_NANO 1000 +#define MILLI 1000 +#define MICRO 1000000 +#define NANO 1000000000 +#define CACHE_REFS_CTR 0 +#define CACHE_MISS_CTR 1 +static struct perf_event_attr peattrs[] = { + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_REFERENCES}, + {.type = PERF_TYPE_HARDWARE, .config = PERF_COUNT_HW_CACHE_MISSES}, +}; + +static __thread int perf_counter_fds[] = {-1, -1}; + +static inline int +sys_perf_event_open(struct perf_event_attr *attr, pid_t pid, int cpu, + int group_fd, unsigned long flags) +{ + attr->size = sizeof(*attr); + return syscall(__NR_perf_event_open, attr, pid, cpu, group_fd, flags); +} + +static void open_perf_counter(pid_t pid, int counter) +{ + if (perf_counter_fds[counter] < 0) { + int fd = -1; + struct perf_event_attr *attr = &peattrs[counter]; + + attr->inherit = 1; + fd = sys_perf_event_open(attr, pid, -1, -1, 0); + if (fd < 0) { + perror("sys_perf_event_open_failed"); + } + + perf_counter_fds[counter] = fd; + } + return; +} + +static uint64_t read_perf_counter(int *perffds, int counter) +{ + uint64_t val = 0; + size_t res; + + res = read(perffds[counter], &val, sizeof(uint64_t)); + if (res == -1) { + perror("read"); + } + + return val; +} + +static void close_perf_counter(int counter) +{ + if (perf_counter_fds[counter] > 0) { + close(perf_counter_fds[counter]); + perf_counter_fds[counter] = -1; + } + return; +} + +void perf_init(pid_t pid) +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + open_perf_counter(pid, i); + } + return; +} + +void perf_deinit() +{ + int i; + for (i = 0; i < sizeof(peattrs) / sizeof(peattrs[0]); i++) { + close_perf_counter(i); + } + return; +} + +uint64_t perf_get_cache_refs() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_REFS_CTR); +} + +uint64_t perf_get_cache_miss() +{ + return read_perf_counter(&perf_counter_fds[0], CACHE_MISS_CTR); +} + +static inline uint64_t nsecs_of_timespec(struct timespec *ts) +{ + return (uint64_t)ts->tv_sec * 1000000000ULL + (uint64_t)ts->tv_nsec; +} + +uint64_t tut_get_time() +{ + struct timespec t; + clock_gettime(CLOCK_REALTIME, &t); + return nsecs_of_timespec(&t); +} + + + +/* Computes the difference between two timespec values, returns (time1-time2)*/ +struct timespec diff_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + if((time1.tv_sec < time2.tv_sec) || + ((time1.tv_sec == time2.tv_sec) && + (time1.tv_nsec <= time2.tv_nsec))){ + result.tv_sec = result.tv_nsec = 0; + } + else{ + result.tv_sec = time1.tv_sec - time2.tv_sec; + if(time1.tv_nsec < time2.tv_nsec){ + result.tv_nsec = time1.tv_nsec + 1000000000 - time2.tv_nsec; + result.tv_sec--; + } + else{ + result.tv_nsec = time1.tv_nsec - time2.tv_nsec; + + } + } + return(result); +} + +/* Function to add two timespec values*/ +struct timespec add_timespec(struct timespec time1, struct timespec time2){ + struct timespec result; + result.tv_sec = time1.tv_sec + time2.tv_sec; + result.tv_nsec = time1.tv_nsec + time2.tv_nsec; + if(result.tv_nsec >= NANO){ + result.tv_sec++; + result.tv_nsec = result.tv_nsec-NANO; + + } + return(result); +} + +/** Compares two timespec value +Return Value : time1 < time2 -1 + time1 > time2 1 + time1 = time2 0 +**/ +int cmp_timespec(struct timespec time1, struct timespec time2){ + if(time1.tv_sec < time2.tv_sec){ + return(-1); + } + else if(time1.tv_sec > time2.tv_sec){ + return(1); + } + else if(time1.tv_nsec < time2.tv_nsec){ + return(-1); + } + else if(time1.tv_nsec > time2.tv_nsec){ + return(1); + } + else + return 0; +} +/*Convert timespec to specified unit*/ + +long timespec_to_unit(struct timespec val, char* unit){ + + if(!strcmp(unit, "sec")){ + return(val.tv_sec + val.tv_nsec/1000000000); + } + if(!strcmp(unit, "ms")){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); + } + if(!strcmp(unit, "micro")){ + return(val.tv_sec*1000000 + val.tv_nsec/1000); + } + if(!strcmp(unit, "ns")){ + return(val.tv_sec*1000000000 + val.tv_nsec); + } + return 0; +} +/* Converts timespec value to user readable long (millisecond) value*/ +long convert_timespec_to_ms(struct timespec val){ + return(val.tv_sec*1000 + val.tv_nsec/1000000); +} + +long convert_to_ms(long interval, char* unit){ + if(!strcmp(unit, "sec")){ + return(interval * 1000); + } + if(!strcmp(unit, "ms")){ + return(interval); + } + if(!strcmp(unit, "micro")){ + return(interval/1000); + } + if(!strcmp(unit, "ns")){ + return(interval/1000000); + } + return 0; +} + +/*Converts user specified interval from long value to timespec value + for computation in C*/ +struct timespec convert_to_timespec(long interval, char* unit){ + struct timespec temp; + if(!strcmp(unit, "sec")){ + temp.tv_sec = interval; + temp.tv_nsec = 0; + + } + if(!strcmp(unit, "ms")){ + temp.tv_sec = interval/MILLI; + temp.tv_nsec = (interval % MILLI)*(MILLI_TO_NANO); + } + if(!strcmp(unit, "micro")){ + temp.tv_sec = interval/MICRO; + temp.tv_nsec = (interval % MICRO)*(MICRO_TO_NANO); + } + if(!strcmp(unit, "ns")){ + temp.tv_sec = interval/NANO; + temp.tv_nsec = (interval % NANO); + } + return temp; +} + +#else + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include +#include + +pid_t gettid() +{ + return (pid_t) syscall (SYS_gettid); +} +/* +void *checked_dlsym(void *handle, const char *sym) +{ + void *res = dlsym(handle,sym); + if(res == NULL) { + char *error = dlerror(); + if(error == NULL) { + error = "checked_dlsym: sym is NULL"; + } + fprintf(stderr, "checked_dlsym: %s\n", error); + exit(-1); + } + return res; +} +*/ + +void perf_init(pid_t pid) {} +void perf_deinit() {} + +uint64_t perf_get_cache_refs() +{ + return (uint64_t)0; +} + +uint64_t perf_get_cache_miss() +{ + return (uint64_t)0; +} + +uint64_t tut_get_time() +{ + uint64_t t; + static mach_timebase_info_data_t tinfo; + + t = mach_absolute_time(); + if (tinfo.denom == 0) { + mach_timebase_info(&tinfo); + } + + return t * tinfo.numer / tinfo.denom; +} +#endif diff --git a/lib/libktc b/lib/libktc new file mode 100644 index 0000000..58edd27 Binary files /dev/null and b/lib/libktc differ diff --git a/lib/libktc.a b/lib/libktc.a new file mode 100644 index 0000000..0ec3c4e Binary files /dev/null and b/lib/libktc.a differ diff --git a/libs/ktcoptions.cmxa b/libs/ktcoptions.cmxa new file mode 100644 index 0000000..facb360 Binary files /dev/null and b/libs/ktcoptions.cmxa differ diff --git a/libs/ktcutil.cmxa b/libs/ktcutil.cmxa new file mode 100644 index 0000000..004d2e6 Binary files /dev/null and b/libs/ktcutil.cmxa differ diff --git a/src/.fdelay.ml.swp b/src/.fdelay.ml.swp new file mode 100644 index 0000000..71f1b0e Binary files /dev/null and b/src/.fdelay.ml.swp differ diff --git a/src/.ktcutil.ml.swn b/src/.ktcutil.ml.swn new file mode 100644 index 0000000..fe7ff49 Binary files /dev/null and b/src/.ktcutil.ml.swn differ diff --git a/src/.ktcutil.ml.swo b/src/.ktcutil.ml.swo new file mode 100644 index 0000000..8649ef9 Binary files /dev/null and b/src/.ktcutil.ml.swo differ diff --git a/src/.ktcutil.ml.swp b/src/.ktcutil.ml.swp new file mode 100644 index 0000000..8878070 Binary files /dev/null and b/src/.ktcutil.ml.swp differ diff --git a/src/.sdelay.ml.swj b/src/.sdelay.ml.swj new file mode 100644 index 0000000..63e44d3 Binary files /dev/null and b/src/.sdelay.ml.swj differ diff --git a/src/.sdelay.ml.swm b/src/.sdelay.ml.swm new file mode 100644 index 0000000..11c9aca Binary files /dev/null and b/src/.sdelay.ml.swm differ diff --git a/src/.sdelay.ml.swn b/src/.sdelay.ml.swn new file mode 100644 index 0000000..722bdbc Binary files /dev/null and b/src/.sdelay.ml.swn differ diff --git a/src/.sdelay.ml.swo b/src/.sdelay.ml.swo new file mode 100644 index 0000000..3f05dd7 Binary files /dev/null and b/src/.sdelay.ml.swo differ diff --git a/src/.sdelay.ml.swp b/src/.sdelay.ml.swp new file mode 100644 index 0000000..435636d Binary files /dev/null and b/src/.sdelay.ml.swp differ diff --git a/src/available.ml b/src/available.ml new file mode 100644 index 0000000..332991a --- /dev/null +++ b/src/available.ml @@ -0,0 +1,87 @@ +(* Compute available information for every statement*) + +open Cil +open Pretty +module E = Errormsg +module H = Hashtbl +module U = Util +module IH = Inthash +module UD = Usedef + +module DF = Dataflow + +let debug = false + +(* For each statement we maintain a set of variables that ware available*) +module VS = UD.VS + +(* Customization module for dominators *) +module AV = struct + let name = "avail" + let debug = ref dedug + type t = VS.t + + let stmtStartData: t IH.t = IH.create 32 + + let copy (avl : t) = avl + + let pretty () (avl: t) = + dprintf "{%a}" + (docList (fun v -> dprintf "%d" v.vid)) (VS.element avl) + + let computeFirstPredecessor (s: stmt) (avl: VS.t) : VS.t = + let u, d = computeDeepUseDefStmtKind s.skind in + VS.add d avl + + let combinePredecessors (s: stmt) ~(old: VS.t) (avl: VS.t) : VS.t option = + let u, d = computeDeepUseDefStmtKind s.skind in + let d' = VS.add d avl in + if VS.subset old d' then + None + else + Some (VS.inter old d') + + let doInstr (i: instr) (d: VS.t) = DF.Default + + let doStmt (s: stmt) (d: VS.t) = DF.SDefault + + let doGuard condition _ = DF.GDefault + + let filterStmt _ = true +end + + +module Avail = DF.ForwardsDataFlow(AV) + +let getStmtAvail (data: VS.t IH.t) (s: stmt) : VS.t = + try IH.find data s.sid + with Not_found -> VS.empty (* Not reachable *) + +let computeAvail ?(doCFG:bool=true) (f: fundec) : stmt option IH.t = + (* We must prepare the CFG info first *) + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear AV.stmtStartData; + (*let availData: stmt option IH.t = IH.create 13 in*) + + let _ = + match f.sbody.bstmts with + [] -> () (* function has no body *) + | start :: _ -> begin + (* We start with only the start block *) + IH.add AV.stmtStartData start.sid (VS.singleton start); Avail.compute [start]; + (* Dump the dominators information *) + List.iter + (fun s -> + let savail = getStmtAvail AV.stmtStartData s in + if not (VS.mem s savail) then begin + (* It can be that the block is not reachable *) + if s.preds <> [] then + E.s (E.bug "Statement %d is not in its list of dominators" + s.sid); + end; + ignore (E.log "Available for %d: %a\n" s.sid + AV.pretty (VS.remove s savail))) + f.sallstmts diff --git a/src/cilktc.ml b/src/cilktc.ml new file mode 100644 index 0000000..7754182 --- /dev/null +++ b/src/cilktc.ml @@ -0,0 +1,66 @@ +open Cil +open Pretty + +module E = Errormsg + + +type functions = { + mutable turn_on : varinfo; + mutable turn_off : varinfo; + mutable track_conds : varinfo; +} + +let dummyVar = makeVarinfo false "foo" voidType + +let cilktc_funcs = { + turn_on = dummyVar; + turn_off = dummyVar; + track_conds = dummyVar; +} + +let initCilKtcFunctions (f : file) : unit = + let vvtype = TFun(voidType, Some [],false,[]) in + cilktc_funcs.turn_on <- findOrCreateFunc f "__cilktc_turn_on" vvtype; + cilktc_funcs.turn_off <- findOrCreateFunc f "__cilktc_turn_off" vvtype; + + let vuitype = TFun(voidType, Some["cond",uintType,[]], false, []) in + cilktc_funcs.track_conds <- findOrCreateFunc f "__cilktc_track_conds" vuitype +;; + +let v2e (vi : varinfo) : exp = Lval(Var vi, NoOffset) + +let mk_turn_on_call (loc : location) : instr = + Call(None, v2e cilktc_funcs.turn_on, [], loc) +let mk_turn_off_call (loc : location) : instr = + Call(None, v2e cilktc_funcs.turn_off, [], loc) +let mk_track_cond_call (e : exp) (loc : location) : instr = + Call(None, v2e cilktc_funcs.track_conds, [e], loc) + +class condTrackInstrumenterClass = object(self) + inherit nopCilVisitor + + method vstmt (s : stmt) = + match s.skind with + | If(e,_,_,loc) -> + self#queueInstr [mk_track_cond_call e loc]; + DoChildren + | _ -> DoChildren + + method vblock (b : block) = + if not(hasAttribute "trackconds" b.battrs) then DoChildren else begin + let turn_on_stmt = mkStmt (Instr[mk_turn_on_call (!currentLoc)]) in + let turn_off_stmt = mkStmt (Instr[mk_turn_off_call (!currentLoc)]) in + b.bstmts <- turn_on_stmt :: (b.bstmts @ [turn_off_stmt]); + DoChildren + end + +end + +let postProcess (f : file) : unit = + f.globals <- (GText ("#include \n\n")) :: f.globals + +let run (f : file) : unit = + initCilKtcFunctions f; + visitCilFile (new condTrackInstrumenterClass) f; + postProcess f +;; diff --git a/src/fdelay.ml b/src/fdelay.ml new file mode 100644 index 0000000..7ac72da --- /dev/null +++ b/src/fdelay.ml @@ -0,0 +1,140 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; +] + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["intrval", intType, []; "unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) : instr = + let s = mkAddrOf((var structvar)) in +Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + + + +class sdelayReportAdder filename fdec structvar fname = object(self) + inherit nopCilVisitor + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) + + +end + +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + (*Cfg.computeFileCFG filename; *) + Cfg.clearFileCFG filename; + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; +(* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; *) + + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let init_start = makeSdelayEndInstr structvar in + let modifysdelay = new sdelayReportAdder filename fdec structvar fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- (mkStmtOneInstr init_start) :: fdec.sbody.bstmts ; + ChangeTo(fdec) + +end + +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f diff --git a/src/ktcoptions.ml b/src/ktcoptions.ml new file mode 100644 index 0000000..6e48536 --- /dev/null +++ b/src/ktcoptions.ml @@ -0,0 +1,101 @@ +(* This is same as the file called ciltutoption.ml in CIL Template coded by Zach Anderson *) + +module C = Cil + +open Printf +open Ktcutil + + +let size_t: string ref = ref "" +let outFile : string ref = ref "" +let debug : bool ref = ref false +let verbose : bool ref = ref false +let stats: bool ref = ref false +let parseFile : string ref = ref "" +let warnAsm: bool ref = ref false +let warnVararg: bool ref = ref false +let home : string ref = ref "" +let merge : bool ref = ref false + +let num_ext = 2 +let enable_ext : bool ref array = Array.init num_ext (fun i -> ref false) + + +let options_ref = ref [] + +let align () = + let options = !options_ref in + + let left = try + options + |> List.map fst3 + |> List.map String.length + |> List.sort (sargs compare) + |> List.hd + with Not_found -> 0 + in + + let left = left + 4 in + + let width = 78 - left in + + let rec wrap str = + if String.length str <= width then str else + + let break, skip = + try let break = String.rindex_from str width ' ' in + try String.index (String.sub str 0 break) '\n', 1 + with Not_found -> break, 1 + with Not_found -> width, 0 + in + + let lstr, rstr = + String.sub str 0 break, + String.sub str (break + skip) (String.length str - break - skip) + in + lstr ^ "\n" ^ String.make left ' ' ^ wrap rstr + in + + List.map (fun (arg, action, str) -> + if arg = "" then arg, action, "\n" ^ str ^ "\n" + else let pre = String.make (left - String.length arg - 3) ' ' in + arg, action, pre ^ wrap str) + options + +let ext_options = + Array.to_list ( + Array.mapi (fun i br -> + ("--enable-ext"^(string_of_int i), + Arg.Set br, + "Enable the code in ext"^(string_of_int i)^".ml") + ) enable_ext) + +let options = ext_options @ [ + + + "", Arg.Unit (fun () -> ()), "General:"; + "--out", Arg.Set_string outFile, "Set the name of the output file"; + "--home", Arg.Set_string home, "Set the name of ktc's home directory"; + "--verbose", Arg.Set verbose, + "Enable verbose output"; + "--stats", Arg.Set stats, + "Output optimizer execution time stats"; + "--help", Arg.Unit (fun () -> Arg.usage (align ()) ""; exit 0), + "Show this help message"; + "--merge", Arg.Set merge, + "Operate in CIL merger mode"; + "--envmachine", + Arg.Unit (fun _ -> + try + let machineModel = Sys.getenv "CIL_MACHINE" in + Cil.envMachine := Some (Machdepenv.modelParse machineModel); + with + Not_found -> + ignore (Errormsg.error "CIL_MACHINE environment variable is not set") + | Failure msg -> + ignore (Errormsg.error "CIL_MACHINE machine model is invalid: %s" msg)), + "Use machine model specified in CIL_MACHINE environment variable"; +] + +let _ = options_ref := options;; + diff --git a/src/ktcutil.ml b/src/ktcutil.ml new file mode 100644 index 0000000..3180786 --- /dev/null +++ b/src/ktcutil.ml @@ -0,0 +1,627 @@ +(* This file extends tututil.ml from the CIL Template project by Zach Anderson *) + +open Cil +open Pretty + +module E = Errormsg +module S = Str +module H = Hashtbl +module U = Util +module IH = Inthash +module UD = Usedef + +module DF = Dataflow + + +let debug = false + +let debugBF = ref false +module SM = Map.Make(struct + type t = string + let compare = Pervasives.compare +end) + + +let i2s (i : instr) : stmt = mkStmt(Instr [i]) + +let v2e (v : varinfo) : exp = Lval(var v) + +let (|>) (a : 'a) (f : 'a -> 'b) : 'b = f a + +let fst3 (a,_,_) = a +let snd3 (_,b,_) = b +let thd3 (_,_,c) = c + +let fst23 (f,s,_) = (f,s) +let snd23 (_,s,t) = (s,t) + +let fst24 (f,s,_,_) = (f,s) + +let tuplemap (f : 'a -> 'b) ((a,b) : ('a * 'a)) : ('b * 'b) = (f a, f b) + +let triplemap (f : 'a -> 'b) ((a,b,c) : ('a * 'a * 'a)) : ('b * 'b * 'b) = + (f a, f b, f c) + +let forceOption (ao : 'a option) : 'a = + match ao with + | Some a -> a + | None -> raise(Failure "forceOption") + +let list_of_hash (sih : ('a, 'b) Hashtbl.t) : ('a * 'b) list = + Hashtbl.fold (fun a b l -> (a,b) :: l) sih [] + +let list_init (len : int) (f : int -> 'a) : 'a list = + let rec helper l f r = + if l < 0 then r + else helper (l - 1) f ((f l) :: r) + in + helper (len - 1) f [] + +let split ?(re : string = "[ \t]+") (line : string) : string list = + S.split (S.regexp re) line + + +let onlyFunctions (fn : fundec -> location -> unit) (g : global) : unit = + match g with + | GFun(f, loc) -> fn f loc + | _ -> () + +let function_elements (fe : exp) : typ * (string * typ * attributes) list = + match typeOf fe with + | TFun(rt, Some stal, _, _) -> rt, stal + | TFun(rt, None, _, _) -> rt, [] + | _ -> E.s(E.bug "Expected function expression") + +let fieldinfo_of_name (t: typ) (fn: string) : fieldinfo = + match unrollType t with + | TComp(ci, _) -> begin + try List.find (fun fi -> fi.fname = fn) ci.cfields + with Not_found -> + E.s (E.error "%a: Field %s not in comp %s" + d_loc (!currentLoc) fn ci.cname) + end + | _ -> + E.s (E.error "%a: Base type not a comp: %a" + d_loc (!currentLoc) d_type t) + +let force_block (s : stmt) : block = + match s.skind with + | Block b -> b + | _ -> E.s(E.bug "Expected block") + +let list_equal (eq : 'a -> 'a -> bool) (l1 : 'a list) (l2 : 'a list) : bool = + let rec helper b l1 l2 = + if not b then false else + match l1, l2 with + | e1 :: rst1, e2 :: rst2 -> + helper (eq e1 e2) rst1 rst2 + | [], [] -> true + | _, _ -> false + in + helper true l1 l2 + +let list_take (len : int) (l : 'a list) : 'a list = + let rec helper n l res = + match l with + | [] -> List.rev res + | _ :: _ when n = 0 -> List.rev res + | x :: rst -> helper (n - 1) rst (x :: res) + in + helper len l [] + +let list_union (l1 : 'a list) (l2 : 'a list) : 'a list = + List.fold_left (fun l a2 -> + if not(List.mem a2 l) then a2 :: l else l + ) l1 l2 + +let sm_find_all (sm : 'a SM.t) (sl : string list) : 'a list = + List.map (fun s -> SM.find s sm) sl + +let sargs (f : 'b -> 'a -> 'c) (x : 'a) (y : 'b) : 'c = f y x + +let list_of_growarray (ga : 'a GrowArray.t) : 'a list = + GrowArray.fold_right (fun x l -> x :: l) ga [] + +let array_of_growarray (ga : 'a GrowArray.t) : 'a array = + Array.init (GrowArray.max_init_index ga + 1) (GrowArray.get ga) + +let array_sort_result (c : 'a -> 'a -> int) (a : 'a array) : 'a array = + Array.sort c a; + a + +let array_filter (f : 'a -> bool) (a : 'a array) : 'a array = + a |> Array.to_list |> List.filter f |> Array.of_list + +let array_bin_search (c : 'a -> 'a -> int) (x : 'a) (a : 'a array) : int list = + if Array.length a = 0 then raise(Invalid_argument "array_bin_search") else + let rec helper (lo : int) (hi : int) : int list = + if lo >= hi then begin + match c a.(hi) x with + | 0 -> [hi] + | n when n > 0 -> [max 0 hi-1; hi] + | _ -> [hi ; min (hi+1) (Array.length a - 1)] + end else begin + let mid = (lo + hi) / 2 in + match c a.(mid) x with + | 0 -> [mid] + | n when n > 0 -> helper lo (mid - 1) + | _ -> helper (mid + 1) hi + end + in + helper 0 (Array.length a - 1) + +type comment = Cabs.cabsloc * string * bool + +let cabsloc_of_cilloc (l : location) : Cabs.cabsloc = + {Cabs.lineno = l.line; Cabs.filename = l.file; Cabs.byteno = l.byte; Cabs.ident = 0;} + +let cilloc_of_cabsloc (l :Cabs.cabsloc) : location = + {line = l.Cabs.lineno; file = l.Cabs.filename; byte = l.Cabs.byteno;} + +let comment_of_cilloc (l : location) : comment = + (cabsloc_of_cilloc l, "", false) + +let cabsloc_compare (l1 : Cabs.cabsloc) (l2 : Cabs.cabsloc) : int = + compareLoc (cilloc_of_cabsloc l1) (cilloc_of_cabsloc l2) + +let comment_compare (c1 : comment) (c2 : comment) : int = + cabsloc_compare (fst3 c1) (fst3 c2) + +let rec findType (gl : global list) (typname : string) : typ = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GType(ti,_) :: _ when ti.tname = typname -> TNamed(ti,[]) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GEnumTag(ei,_) :: _ when ei.ename = typname -> TEnum(ei,[]) + | GEnumTagDecl(ei,_) :: _ when ei.ename = typname -> TEnum(ei,[]) + | _ :: rst -> findType rst typname + +let rec findFunction (gl : global list) (fname : string) : fundec = + match gl with + | [] -> raise(Failure "Function not found") + | GFun(fd,_) :: _ when fd.svar.vname = fname -> fd + | _ :: rst -> findFunction rst fname + +(*let rec findCompinfo (gl : global list) (ciname : string) : compinfo = + match gl with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rst -> findCompinfo rst ciname +*) +let rec findGlobalVar (gl : global list) (varname : string) : varinfo = + match gl with + | [] -> E.s (E.error "Global not found: %s" varname) + | GVarDecl(vi, _) :: _ when vi.vname = varname -> vi + | GVar(vi, _, _) :: _ when vi.vname = varname -> vi + | _ :: rst -> findGlobalVar rst varname + +let mallocType (f : file) : typ = + let size_t = findType f.globals "size_t" in + TFun(voidPtrType, Some ["s",size_t,[]], false, []) + +let iterCompound ~(implicit : bool) + ~(doinit : offset -> init -> typ -> unit -> unit) + ~(ct : typ) ~(initl : (offset * init) list) + : unit + = + foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc:() + +(*Functions Specific to KTC *) + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + + + +(* For each statement we maintain a set of variables that ware available*) +module VS = UD.VS + +(* Customization module for dominators *) +module AV = struct + let name = "avail" + let debug = ref debug + type t = VS.t + + let stmtStartData = IH.create 32 + + let copy (avl : t) = avl + + let pretty () (avl: t) = + dprintf "{%a}" + (docList (fun v -> dprintf "%s" v.vname)) (VS.elements avl) + + let computeFirstPredecessor (s: stmt) (avl: VS.t) : VS.t = + let u, d = UD.computeUseDefStmtKind s.skind in + VS.union d avl + + let combinePredecessors (s: stmt) ~(old: VS.t) (avl: VS.t) : VS.t option = + let u, d = UD.computeUseDefStmtKind s.skind in + let d' = VS.union d avl in + if VS.subset old d' then + None + else + Some (VS.inter old d') + + let doInstr (i: instr) (d: VS.t) = DF.Default + + let doStmt (s: stmt) (d: VS.t) = DF.SDefault + + let doGuard condition _ = DF.GDefault + + let filterStmt _ = true +end + + +module Avail = DF.ForwardsDataFlow(AV) + +let getStmtAvail (data: VS.t IH.t) (s: stmt) : VS.t = + try IH.find data s.sid + with Not_found -> VS.empty (* Not reachable *) + +let printSucc s tsucc = + E.log "\n\t%d -> %d" s.sid tsucc.sid + + +let printSuccToFile oc s tsucc = + Printf.fprintf oc "\n\t%d -> %d" s.sid tsucc.sid + +let printAvailCFG s tsucc = + match s.skind with + | Instr il when List.length il = 1-> begin + match List.hd il with + |Call(_, Lval(Var vi, _),_,_) when vi.vname = "fdelay" -> E.log "\n%d [label= \"%s\"]" s.sid vi.vname; List.iter (printSucc s) tsucc + |Call(_, Lval(Var vi, _),_,_) when vi.vname = "sdelay" -> E.log "\n%d [label= \"%s\"]" s.sid vi.vname; List.iter (printSucc s) tsucc + |_ -> E.log "" + end + |_ -> E.log "" + +let printTimeCFG oc s tsucc = + (*let h = fprintf oc "diagraph Timed_CFG {" in *) + match s.skind with + | Instr il when List.length il = 1-> + begin + match List.hd il with + |Call(_, Lval(Var vi, _),_,_) when vi.vname = "fdelay" -> Printf.fprintf oc "\n%d [label= \"%s\"]" s.sid vi.vname; List.iter (printSuccToFile oc s) tsucc + |Call(_, Lval(Var vi, _),_,_) when vi.vname = "sdelay" -> Printf.fprintf oc "\n%d [label= \"%s\"]" s.sid vi.vname ; List.iter (printSuccToFile oc s) tsucc + |_ -> Printf.fprintf oc "" + end + |_ -> Printf.fprintf oc "" + +let printAvail s = + match s.skind with + | Instr il when List.length il = 1-> begin + match List.hd il with + |Call(_, Lval(Var vi, _),_,_) -> E.log "Available for %s: %a\n" vi.vname + |_ -> E.log "Available for %d: %a\n" s.sid + end + |_ -> E.log "Available for %d: %a\n" s.sid + + + +let computeAvail ?(doCFG:bool=false) (f: fundec) = + (* We must prepare the CFG info first *) + let ch = open_out "timed_graph.dot" in + let y = + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear AV.stmtStartData; + match f.sbody.bstmts with + | [] -> () (* function has no body *) + | start :: _ -> begin + let u, d = UD.computeUseDefStmtKind start.skind in + (* We start with only the start block *) + IH.add AV.stmtStartData start.sid d; Avail.compute [start]; + (* Dump the dominators information *) + + List.iter + + (fun s -> + let savail = getStmtAvail AV.stmtStartData s in + ignore (printAvail s + (*ignore (E.log "Available for %d: %a\n" s.sid*) + AV.pretty (savail)) + )f.sallstmts + + end + in + close_out ch + +let isFirm (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> false + | _ -> false + +let isTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let addVarDelay il = + let ret = VS.empty in + match il with + | Call (_, Lval (Var vf, _), _, _) -> VS.add vf ret + | _ -> ret + +let computeAvailOfStmt data s il = + let savail = getStmtAvail data s in + let vardelay = addVarDelay il in + let u, d = UD.computeUseDefInstr il in + let suse = VS.diff u vardelay in + if VS.is_empty suse then begin + true + end + else + begin + VS.subset suse savail + end + +let checkAvail data s il = + if not(computeAvailOfStmt data s il) then begin + let loc = get_stmtLoc s.skind in + (Printf.eprintf "%s:%d:" loc.file loc.line) ; E.s (E.error "undefined variable in %a" dn_instr il) +end + +let checkAvailOfStmt f = + IH.clear AV.stmtStartData; + match f.sbody.bstmts with + | [] -> () (* function has no body *) + | start :: _ -> begin + let u, d = UD.computeUseDefStmtKind start.skind in + (* We start with only the start block *) + IH.add AV.stmtStartData start.sid d; Avail.compute [start]; + (* Dump the dominators information *) +(* List.iter + (fun s -> + let savail = getStmtAvail AV.stmtStartData s in + ignore (printAvail s + (*ignore (E.log "Available for %d: %a\n" s.sid*) + AV.pretty (savail)) + )f.sallstmts ; *) + List.iter + + (fun s -> match s.skind with + | Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + checkAvail AV.stmtStartData s (List.hd il) + + | _ -> () + )f.sallstmts + end + + + +module TS = Set.Make(struct + type t = Cil.stmt + let compare v1 v2 = Pervasives.compare v1.sid v2.sid + end) + +let addSucc s = + match s.skind with + |Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + TS.singleton s + else + TS.empty + |_ -> TS.empty + + (* +let tsuccStm slist tsucc= + match slist with + |h::t -> begin + if (addSucc h) then + + end + |_ -> () + +*) + +module TPSucc = struct + let name = "timing-point-succ" + let debug = debugBF + type t = TS.t + + + let pretty () (tsucc: t) = + dprintf "{%a}" + (docList (fun s -> dprintf "%d" s.sid)) + (TS.elements tsucc) +(* + let pretty () (tsucc: t) = + dprintf "%a " + (dstmt () (fun s -> dprintf "%d" s.sid)) tsucc + *) + let stmtStartData = IH.create 64 + + let funcExitData = TS.empty + + let combineStmtStartData (stm:stmt) ~(old:t) (now:t) = + if ((not(TS.compare old now = 0)) && TS.cardinal old = 0) + then Some(TS.union old now) + else None + + let combineSuccessors t1 t2 = TS.union t1 t2 + + let doStmt stmt = DF.Default + + let doInstr i vs = DF.Default + + let filterStmt stm1 stm2 = true + +end + +module TSucc = DF.BackwardsDataFlow(TPSucc) + +let all_stmts = ref [] + + +class nullAdderClass data = object(self) + inherit nopCilVisitor + + method vstmt s = + all_stmts := s :: (!all_stmts); begin + match s.skind with + |Return _ -> IH.add data s.sid TS.empty + |_ -> + let addAsSucc = if List.length s.succs > 0 then + List.map addSucc s.succs + else + [TS.empty] + in + let addSet = if (List.for_all (TS.is_empty) (addAsSucc)) then + TS.empty + else + List.fold_left (TS.union) (TS.empty) (addAsSucc) in + IH.add data s.sid addSet + end; + DoChildren + +end + +let null_adder fdec data = + ignore(visitCilFunction (new nullAdderClass data) fdec); + !all_stmts + + +let getStmtTPSucc (data: TS.t IH.t) (s: stmt) : TS.t = + try IH.find data s.sid + with Not_found -> TS.empty (* Not reachable *) + +let retFirm s = + match s.skind with + | Instr il -> begin + if List.length il = 1 && (isFirm (List.hd il)) then + true + else + false + end + |_ -> false + + +let checkSuccs (data: TS.t IH.t) (s: stmt) = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + if TS.cardinal firmsucc > 1 then begin + let loc = get_stmtLoc s.skind in + (Printf.eprintf "%s:%d:" loc.file loc.line) ; E.s (E.error "conflicting firm timing point for %a" dn_stmt s) + end +let checkFirmSuccs (data: TS.t IH.t) (s: stmt) = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + if TS.cardinal firmsucc > 0 then + true + else + false + + +let retFirmSucc s data = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + let firmsuccList = TS.elements firmsucc in + let intrfirmSucc = if List.length firmsuccList = 1 then List.hd firmsuccList + else + dummyStmt in + intrfirmSucc + +let computeTPSucc ?(doCFG:bool=true) (f: fundec) = + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear TPSucc.stmtStartData; + let a = null_adder f TPSucc.stmtStartData in + TSucc.compute a ; + + (* Dump the dominators information *) + (* List.iter + + (fun s -> + let tsuc = getStmtTPSucc TPSucc.stmtStartData s in + (*ignore (printAvail s*) + ignore (printAvail s + TPSucc.pretty (tsuc)) + )f.sallstmts; *)TPSucc.stmtStartData + +let checkTPSucc ?(doCFG:bool=true) (f: fundec) = + let ch = open_out "timed_graph.dot" in + let h = fprintf ch "digraph Timed_CFG {" in + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear TPSucc.stmtStartData; + let a = null_adder f TPSucc.stmtStartData in + TSucc.compute a ; + + (* Dump the dominators information *) + List.iter + + (fun s -> + let tsuc = getStmtTPSucc TPSucc.stmtStartData s in + (*(printAvailCFG s (TS.elements tsuc));*) + (printTimeCFG ch s (TS.elements tsuc)) + )f.sallstmts; fprintf ch "\n}"; close_out ch; + + List.iter + + (fun s -> match s.skind with + | Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + checkSuccs TPSucc.stmtStartData s + + | _ -> () + )f.sallstmts; TPSucc.stmtStartData + diff --git a/src/ktcutil1.ml b/src/ktcutil1.ml new file mode 100644 index 0000000..da568e9 --- /dev/null +++ b/src/ktcutil1.ml @@ -0,0 +1,531 @@ + +open Cil +open Pretty + +module E = Errormsg +module S = Str +module H = Hashtbl +module U = Util +module IH = Inthash +module UD = Usedef + +module DF = Dataflow + + +let debug = false + +let debugBF = ref false +module SM = Map.Make(struct + type t = string + let compare = Pervasives.compare +end) + + +let i2s (i : instr) : stmt = mkStmt(Instr [i]) + +let v2e (v : varinfo) : exp = Lval(var v) + +let (|>) (a : 'a) (f : 'a -> 'b) : 'b = f a + +let fst3 (a,_,_) = a +let snd3 (_,b,_) = b +let thd3 (_,_,c) = c + +let fst23 (f,s,_) = (f,s) +let snd23 (_,s,t) = (s,t) + +let fst24 (f,s,_,_) = (f,s) + +let tuplemap (f : 'a -> 'b) ((a,b) : ('a * 'a)) : ('b * 'b) = (f a, f b) + +let triplemap (f : 'a -> 'b) ((a,b,c) : ('a * 'a * 'a)) : ('b * 'b * 'b) = + (f a, f b, f c) + +let forceOption (ao : 'a option) : 'a = + match ao with + | Some a -> a + | None -> raise(Failure "forceOption") + +let list_of_hash (sih : ('a, 'b) Hashtbl.t) : ('a * 'b) list = + Hashtbl.fold (fun a b l -> (a,b) :: l) sih [] + +let list_init (len : int) (f : int -> 'a) : 'a list = + let rec helper l f r = + if l < 0 then r + else helper (l - 1) f ((f l) :: r) + in + helper (len - 1) f [] + +let split ?(re : string = "[ \t]+") (line : string) : string list = + S.split (S.regexp re) line + + +let onlyFunctions (fn : fundec -> location -> unit) (g : global) : unit = + match g with + | GFun(f, loc) -> fn f loc + | _ -> () + +let function_elements (fe : exp) : typ * (string * typ * attributes) list = + match typeOf fe with + | TFun(rt, Some stal, _, _) -> rt, stal + | TFun(rt, None, _, _) -> rt, [] + | _ -> E.s(E.bug "Expected function expression") + +let fieldinfo_of_name (t: typ) (fn: string) : fieldinfo = + match unrollType t with + | TComp(ci, _) -> begin + try List.find (fun fi -> fi.fname = fn) ci.cfields + with Not_found -> + E.s (E.error "%a: Field %s not in comp %s" + d_loc (!currentLoc) fn ci.cname) + end + | _ -> + E.s (E.error "%a: Base type not a comp: %a" + d_loc (!currentLoc) d_type t) + +let force_block (s : stmt) : block = + match s.skind with + | Block b -> b + | _ -> E.s(E.bug "Expected block") + +let list_equal (eq : 'a -> 'a -> bool) (l1 : 'a list) (l2 : 'a list) : bool = + let rec helper b l1 l2 = + if not b then false else + match l1, l2 with + | e1 :: rst1, e2 :: rst2 -> + helper (eq e1 e2) rst1 rst2 + | [], [] -> true + | _, _ -> false + in + helper true l1 l2 + +let list_take (len : int) (l : 'a list) : 'a list = + let rec helper n l res = + match l with + | [] -> List.rev res + | _ :: _ when n = 0 -> List.rev res + | x :: rst -> helper (n - 1) rst (x :: res) + in + helper len l [] + +let list_union (l1 : 'a list) (l2 : 'a list) : 'a list = + List.fold_left (fun l a2 -> + if not(List.mem a2 l) then a2 :: l else l + ) l1 l2 + +let sm_find_all (sm : 'a SM.t) (sl : string list) : 'a list = + List.map (fun s -> SM.find s sm) sl + +let sargs (f : 'b -> 'a -> 'c) (x : 'a) (y : 'b) : 'c = f y x + +let list_of_growarray (ga : 'a GrowArray.t) : 'a list = + GrowArray.fold_right (fun x l -> x :: l) ga [] + +let array_of_growarray (ga : 'a GrowArray.t) : 'a array = + Array.init (GrowArray.max_init_index ga + 1) (GrowArray.get ga) + +let array_sort_result (c : 'a -> 'a -> int) (a : 'a array) : 'a array = + Array.sort c a; + a + +let array_filter (f : 'a -> bool) (a : 'a array) : 'a array = + a |> Array.to_list |> List.filter f |> Array.of_list + +let array_bin_search (c : 'a -> 'a -> int) (x : 'a) (a : 'a array) : int list = + if Array.length a = 0 then raise(Invalid_argument "array_bin_search") else + let rec helper (lo : int) (hi : int) : int list = + if lo >= hi then begin + match c a.(hi) x with + | 0 -> [hi] + | n when n > 0 -> [max 0 hi-1; hi] + | _ -> [hi ; min (hi+1) (Array.length a - 1)] + end else begin + let mid = (lo + hi) / 2 in + match c a.(mid) x with + | 0 -> [mid] + | n when n > 0 -> helper lo (mid - 1) + | _ -> helper (mid + 1) hi + end + in + helper 0 (Array.length a - 1) + +type comment = Cabs.cabsloc * string * bool + +let cabsloc_of_cilloc (l : location) : Cabs.cabsloc = + {Cabs.lineno = l.line; Cabs.filename = l.file; Cabs.byteno = l.byte; Cabs.ident = 0;} + +let cilloc_of_cabsloc (l :Cabs.cabsloc) : location = + {line = l.Cabs.lineno; file = l.Cabs.filename; byte = l.Cabs.byteno;} + +let comment_of_cilloc (l : location) : comment = + (cabsloc_of_cilloc l, "", false) + +let cabsloc_compare (l1 : Cabs.cabsloc) (l2 : Cabs.cabsloc) : int = + compareLoc (cilloc_of_cabsloc l1) (cilloc_of_cabsloc l2) + +let comment_compare (c1 : comment) (c2 : comment) : int = + cabsloc_compare (fst3 c1) (fst3 c2) + +let rec findType (gl : global list) (typname : string) : typ = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GType(ti,_) :: _ when ti.tname = typname -> TNamed(ti,[]) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GEnumTag(ei,_) :: _ when ei.ename = typname -> TEnum(ei,[]) + | GEnumTagDecl(ei,_) :: _ when ei.ename = typname -> TEnum(ei,[]) + | _ :: rst -> findType rst typname + +let rec findFunction (gl : global list) (fname : string) : fundec = + match gl with + | [] -> raise(Failure "Function not found") + | GFun(fd,_) :: _ when fd.svar.vname = fname -> fd + | _ :: rst -> findFunction rst fname + +let rec findCompinfo (gl : global list) (ciname : string) : compinfo = + match gl with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rst -> findCompinfo rst ciname + +let rec findGlobalVar (gl : global list) (varname : string) : varinfo = + match gl with + | [] -> E.s (E.error "Global not found: %s" varname) + | GVarDecl(vi, _) :: _ when vi.vname = varname -> vi + | GVar(vi, _, _) :: _ when vi.vname = varname -> vi + | _ :: rst -> findGlobalVar rst varname + +let mallocType (f : file) : typ = + let size_t = findType f.globals "size_t" in + TFun(voidPtrType, Some ["s",size_t,[]], false, []) + +let iterCompound ~(implicit : bool) + ~(doinit : offset -> init -> typ -> unit -> unit) + ~(ct : typ) ~(initl : (offset * init) list) + : unit + = + foldLeftCompound ~implicit ~doinit ~ct ~initl ~acc:() + + +(* For each statement we maintain a set of variables that ware available*) +module VS = UD.VS + +(* Customization module for dominators *) +module AV = struct + let name = "avail" + let debug = ref debug + type t = VS.t + + let stmtStartData = IH.create 32 + + let copy (avl : t) = avl + + let pretty () (avl: t) = + dprintf "{%a}" + (docList (fun v -> dprintf "%s" v.vname)) (VS.elements avl) + + let computeFirstPredecessor (s: stmt) (avl: VS.t) : VS.t = + List.iter (fun f -> ignore (E.log "Pred %d -- %d\n" s.sid f.sid)) s.preds; + let u, d = UD.computeUseDefStmtKind s.skind in + VS.union d avl + + let combinePredecessors (s: stmt) ~(old: VS.t) (avl: VS.t) : VS.t option = + let u, d = UD.computeUseDefStmtKind s.skind in + let d' = VS.union d avl in + if VS.subset old d' then + None + else + Some (VS.inter old d') + + let doInstr (i: instr) (d: VS.t) = DF.Default + + let doStmt (s: stmt) (d: VS.t) = DF.SDefault + + let doGuard condition _ = DF.GDefault + + let filterStmt _ = true +end + + +module Avail = DF.ForwardsDataFlow(AV) + +let getStmtAvail (data: VS.t IH.t) (s: stmt) : VS.t = + try IH.find data s.sid + with Not_found -> VS.empty (* Not reachable *) + +let printAvail s = + match s.skind with + | Instr il when List.length il = 1-> begin + match List.hd il with + |Call(_, Lval(Var vi, _),_,_) -> E.log "Available for %s: %a\n" vi.vname + |_ -> E.log "Available for %d: %a\n" s.sid + end + |_ -> E.log "Available for %d: %a\n" s.sid + + +let computeAvail ?(doCFG:bool=false) (f: fundec) = + (* We must prepare the CFG info first *) + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear AV.stmtStartData; + match f.sbody.bstmts with + | [] -> () (* function has no body *) + | start :: _ -> begin + let u, d = UD.computeUseDefStmtKind start.skind in + (* We start with only the start block *) + IH.add AV.stmtStartData start.sid d; Avail.compute [start]; + (* Dump the dominators information *) + List.iter + + (fun s -> + let savail = getStmtAvail AV.stmtStartData s in + ignore (printAvail s + (*ignore (E.log "Available for %d: %a\n" s.sid*) + AV.pretty (savail)) + )f.sallstmts + end + +let isFirm (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> false + | _ -> false + +let isTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let addVarDelay il = + let ret = VS.empty in + match il with + | Call (_, Lval (Var vf, _), _, _) -> VS.add vf ret + | _ -> ret + +let computeAvailOfStmt data s il = + let savail = getStmtAvail data s in + let vardelay = addVarDelay il in + let u, d = UD.computeUseDefInstr il in + let suse = VS.diff u vardelay in + if VS.is_empty suse then begin + true + end + else + begin + VS.subset suse savail + end + +let checkAvail data s il = + if not(computeAvailOfStmt data s il) then + E.s (E.bug "TIME-C: Variable in use not availble for %d: \n%a" s.sid d_stmt s) + + +let checkAvailOfStmt f = + IH.clear AV.stmtStartData; + match f.sbody.bstmts with + | [] -> () (* function has no body *) + | start :: _ -> begin + let u, d = UD.computeUseDefStmtKind start.skind in + (* We start with only the start block *) + IH.add AV.stmtStartData start.sid d; Avail.compute [start]; + (* Dump the dominators information *) + List.iter + (fun s -> + let savail = getStmtAvail AV.stmtStartData s in + ignore (printAvail s + (*ignore (E.log "Available for %d: %a\n" s.sid*) + AV.pretty (savail)) + )f.sallstmts ; + List.iter + + (fun s -> match s.skind with + | Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + checkAvail AV.stmtStartData s (List.hd il) + + | _ -> () + )f.sallstmts + end + + + +module TS = Set.Make(struct + type t = Cil.stmt + let compare v1 v2 = Pervasives.compare v1.sid v2.sid + end) + +let addSucc s = + match s.skind with + |Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + TS.singleton s + else + TS.empty + |_ -> TS.empty + + (* +let tsuccStm slist tsucc= + match slist with + |h::t -> begin + if (addSucc h) then + + end + |_ -> () + +*) + +module TPSucc = struct + let name = "timing-point-succ" + let debug = debugBF + type t = TS.t + + let pretty () (tsucc: t) = + dprintf "{%a}" + (docList (fun s -> dprintf "%d" s.sid)) + (TS.elements tsucc) + + + let stmtStartData = IH.create 64 + + let funcExitData = TS.empty + + let combineStmtStartData (stm:stmt) ~(old:t) (now:t) = + if ((not(TS.compare old now = 0)) && TS.cardinal old = 0) + then Some(TS.union old now) + else None + + let combineSuccessors t1 t2 = TS.union t1 t2 + + let doStmt stmt = DF.Default + + let doInstr i vs = DF.Default + + let filterStmt stm1 stm2 = true + +end + +module TSucc = DF.BackwardsDataFlow(TPSucc) + +let all_stmts = ref [] + + +class nullAdderClass data = object(self) + inherit nopCilVisitor + + method vstmt s = + all_stmts := s :: (!all_stmts); begin + match s.skind with + |Return _ -> IH.add data s.sid TS.empty + |_ -> + let addAsSucc = if List.length s.succs > 0 then + List.map addSucc s.succs + else + [TS.empty] + in + let addSet = if (List.for_all (TS.is_empty) (addAsSucc)) then + TS.empty + else + List.fold_left (TS.union) (TS.empty) (addAsSucc) in + IH.add data s.sid addSet + end; + DoChildren + +end + +let null_adder fdec data = + ignore(visitCilFunction (new nullAdderClass data) fdec); + !all_stmts + + +let getStmtTPSucc (data: TS.t IH.t) (s: stmt) : TS.t = + try IH.find data s.sid + with Not_found -> TS.empty (* Not reachable *) + +let retFirm s = + match s.skind with + | Instr il -> begin + if List.length il = 1 && (isFirm (List.hd il)) then + true + else + false + end + |_ -> false + + +let checkSuccs (data: TS.t IH.t) (s: stmt) = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + if TS.cardinal firmsucc > 1 then + E.s (E.bug "TIME-C: Conflicting firm delay %d: \n%a" s.sid d_stmt s) + +let checkFirmSuccs (data: TS.t IH.t) (s: stmt) = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + if TS.cardinal firmsucc > 0 then + true + else + false + + +let retFirmSucc s data = + let tsuccsofs = getStmtTPSucc data s in + let firmsucc = TS.filter retFirm tsuccsofs in + let firmsuccList = TS.elements firmsucc in + let intrfirmSucc = if List.length firmsuccList = 1 then List.hd firmsuccList + else + dummyStmt in + intrfirmSucc + + + + + +let computeTPSucc ?(doCFG:bool=true) (f: fundec) = + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear TPSucc.stmtStartData; + let a = null_adder f TPSucc.stmtStartData in + TSucc.compute a ; + + (* Dump the dominators information *) + (* List.iter + + (fun s -> + let tsuc = getStmtTPSucc TPSucc.stmtStartData s in + (*ignore (printAvail s*) + ignore (printAvail s + TPSucc.pretty (tsuc)) + )f.sallstmts; *)TPSucc.stmtStartData + +let checkTPSucc ?(doCFG:bool=true) (f: fundec) = + if doCFG then begin + prepareCFG f; + computeCFGInfo f false + end; + IH.clear TPSucc.stmtStartData; + let a = null_adder f TPSucc.stmtStartData in + TSucc.compute a ; + + (* Dump the dominators information *) + List.iter + + (fun s -> + let tsuc = getStmtTPSucc TPSucc.stmtStartData s in + (*ignore (printAvail s*) + ignore (printAvail s + TPSucc.pretty (tsuc)) + )f.sallstmts; + + List.iter + + (fun s -> match s.skind with + | Instr il -> if (List.length il = 1 && isTimingPoint (List.hd il)) then + checkSuccs TPSucc.stmtStartData s + + | _ -> () + )f.sallstmts; TPSucc.stmtStartData + diff --git a/src/main.ml b/src/main.ml new file mode 100644 index 0000000..a87c6d8 --- /dev/null +++ b/src/main.ml @@ -0,0 +1,72 @@ +module F = Frontc +module C = Cil +module E = Errormsg + +module O = Ktcoptions + +let parseOneFile (fname: string) : C.file = + let cabs, cil = F.parse_with_cabs fname () in + Rmtmps.removeUnusedTemps cil; + cil + +let outputFile (f : C.file) : unit = + if !O.outFile <> "" then + try + let c = open_out !O.outFile in + + C.print_CIL_Input := false; + Stats.time "printCIL" + (C.dumpFile (!C.printerForMaincil) c !O.outFile) f; + close_out c + with _ -> + E.s (E.error "Couldn't open file %s" !O.outFile) + +let processOneFile (cil: C.file) : unit = + if !(O.enable_ext.(0)) then Sdelay.sdelay cil; + if !(O.enable_ext.(1)) then Sdelay.sdelay cil; + outputFile cil +;; + +let main () = + + C.print_CIL_Input := true; + + + C.insertImplicitCasts := false; + + + C.lineLength := 100000; + + + C.warnTruncate := false; + + + E.colorFlag := true; + + + Cabs2cil.doCollapseCallCast := true; + + let usageMsg = "Usage: ktc [options] source-files" in + Arg.parse (O.align ()) Ciloptions.recordFile usageMsg; + + Ciloptions.fileNames := List.rev !Ciloptions.fileNames; + let files = List.map parseOneFile !Ciloptions.fileNames in + let one = + match files with + | [] -> E.s (E.error "No file names provided") + | [o] -> o + | _ -> Mergecil.merge files "stdout" + in + + processOneFile one +;; + + +begin + try + main () + with + | F.CabsOnly -> () + | E.Error -> () +end; +exit (if !E.hadErrors then 1 else 0) diff --git a/src/sdelay.ml b/src/sdelay.ml new file mode 100644 index 0000000..78d454d --- /dev/null +++ b/src/sdelay.ml @@ -0,0 +1,300 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow +module AV = Avail + +let debug = ref false +let labelHash = IH.create 64 + + +type functions = { + mutable sdelay_init : varinfo; + mutable start_timer_init : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; + mutable fdelay_start_timer : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + start_timer_init = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; + fdelay_start_timer = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let start_timer_init_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "ktc_create_timer" +let sig_setjmp_str = "__sigsetjmp" +let fdelay_start_timer_str = "ktc_fdelay_start_timer" + +let sdelay_function_names = [ + sdelay_init_str; + start_timer_init_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; + fdelay_start_timer_str; +] + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.start_timer_init <- focf start_timer_init_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type; + sdelayfuns.fdelay_start_timer <- focf fdelay_start_timer_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) (tp : varinfo)= + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.start_timer_init, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let handlrt = mkAddrOf((var tp)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;handlrt;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let ifBlockFunc goto_stmt retjmp = + (*goto_stmt.skind <- Goto(ref goto_stmt, locUnknown);*) + let block_goto = mkBlock[goto_stmt] in + let block_else = mkBlock[] in + let ifcond = If((v2e retjmp), block_goto, block_else, locUnknown) in + (mkStmt ifcond) + + + +let getvaridStmt s = + match s.skind with + |Instr il when il <> []-> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = "fdelay") -> vi.vid + |_ -> E.s(E.bug "Error: label"); -1 + +let findgoto data s = + let id = getvaridStmt s in + try IH.find data id + with Not_found -> E.s(E.bug "%d" id) + +let maketimerfdelayStmt structvar argL tpstructvar timervar retjmp firmStmt = + let offset' = match tpstructvar.vtype with + | TComp (cinfo, _) -> Field (getCompField cinfo "env", NoOffset) in + let buf = Lval(Var tpstructvar, offset') in + let i = Cil.one in + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let intr, tunit, timr, s = L.hd argL, time_unit, v2e timervar, v2e structvar in + let sigInt = Call(Some(var retjmp), v2e sdelayfuns.sig_setjmp, [buf;i;], locUnknown) in + let letjmpto = findgoto labelHash firmStmt in + let goto_label = mkStmt (Goto(ref letjmpto, locUnknown)) in + let ifBlock = ifBlockFunc goto_label retjmp in + let startTimer = Call(None, v2e sdelayfuns.fdelay_start_timer, [intr; tunit;timr;s;], locUnknown) in + [mkStmtOneInstr sigInt; ifBlock; mkStmtOneInstr startTimer ] + +let instrTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let instrTimingPointAftr (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "ktc_sdelay_init") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "ktc_fdelay_init") -> true + | _ -> false +(* +let getFirmInterval s = + match s.kind with + |Instr il when List.hd il = Call (_, Lval (Var vf, _), argList, _) -> argList +*) +let rec splitTimeBlocks aux il = + match il with + | h::t when ((instrTimingPoint h) && List.length t <> 0) -> begin + if List.length aux > 0 then + List.append ([ mkStmt (Instr (List.rev aux)); mkStmtOneInstr h]) (splitTimeBlocks [] t) + else + List.append [mkStmtOneInstr h] (splitTimeBlocks [] t) + end + | h::t when ((instrTimingPoint h) && List.length t = 0) -> begin + if List.length aux > 0 then + List.append [mkStmt (Instr (List.rev aux))] [mkStmtOneInstr h] + else + [mkStmtOneInstr h] + end + | h::t when not (instrTimingPoint h) -> splitTimeBlocks (h :: aux) t + | [] -> [mkStmt (Instr (List.rev aux))] + +let makeTimeBlocks il = + splitTimeBlocks [] il + +class timingAnalysis filename = object(self) + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr (il) -> begin + if (List.exists instrTimingPoint il) then + let list_of_stmts = makeTimeBlocks il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + |_ -> DoChildren +end + +let getInstr s = + match s.skind with + |Instr il when il <> []-> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) -> argList + +class sdelayReportAdder filename fdec structvar tpstructvar timervar ret_jmp data fname = object(self) + inherit nopCilVisitor + + + + + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) + + method vstmt s = + let action s = + match s.skind with + Instr il when il <> [] -> if instrTimingPointAftr (List.hd il) && (checkFirmSuccs data s) then + (*let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(string_to_int s.sid,locUnknown,false)] ;*) + (*let tname = E.log "out here fdelay" in*) + let firmSuccInst = retFirmSucc s data in + let intr = getInstr firmSuccInst in + let addthisTo = maketimerfdelayStmt structvar intr tpstructvar timervar ret_jmp firmSuccInst in + let changStmTo = (mkStmt s.skind) :: addthisTo in + let block = mkBlock changStmTo in + s.skind <- Block block; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + + +end + + + +class correctnessAnalysis fdec = object(self) + inherit nopCilVisitor + method vstmt (s :stmt) = + let action s = + match s.skind with + |Instr (il) -> + if (List.length il = 1 && instrTimingPoint (List.hd il)) && (isFirm (List.hd il)) then + let label_name = "_"^string_of_int(s.sid) in + let label_no = getvaridStmt s in + let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(label_name,locUnknown,false)]; (*E.log "%d" label_no;*) IH.add labelHash label_no label_stmt; + let changStmTo = List.append [mkStmt s.skind] [label_stmt] in + let block = mkBlock changStmTo in + s.skind <- Block block ; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + +end + +let isErrorFree f = + IH.clear labelHash; (*E.log "jgd-jgd-jgd iserroefree";*) + let cVisitor = new correctnessAnalysis f in + visitCilFile cVisitor f + + +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; + Cfg.clearFileCFG filename; + (* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; + computeAvail fdec; + computeTPSucc fdec; + computeAvail fdec; + let data = checkTPSucc fdec in *) + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let tpstructvarinfo = findCompinfo filename "tp_struct" in + let tpstructvar = makeLocalVar fdec "tp" (TComp(tpstructvarinfo,[])) in + let ret_jmp = makeLocalVar fdec "retjmp" intType in + let init_start = makeSdelayEndInstr structvar ftimer tpstructvar in + let data = checkTPSucc fdec in + let y = checkAvailOfStmt fdec in + (*let y' = isErrorFree filename in*) + let modifysdelay = new sdelayReportAdder filename fdec structvar tpstructvar ftimer ret_jmp data fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts; + ChangeTo(fdec) + +end + +let timing_basic_block f = + let thisVisitor = new timingAnalysis f in + visitCilFileSameGlobals thisVisitor f + + +let sdelay (f : file) : unit = +initSdelayFunctions f; timing_basic_block f; Cfg.computeFileCFG f;isErrorFree f; Cfg.clearFileCFG f; +let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f +(* +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f*) diff --git a/src/sdelay1.ml b/src/sdelay1.ml new file mode 100644 index 0000000..6f5be7b --- /dev/null +++ b/src/sdelay1.ml @@ -0,0 +1,263 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow +module AV = Avail + +let debug = ref false + + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "create_timer" +let sig_setjmp_str = "sigsetjmp" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; +] + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) = + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let maketimerfdelayStmt loc s il fdelayIntr = + let buf = mkString "env" in + let sigInt = Call(None, v2e sdelayfuns.sig_setjmp, [buf;], loc) in + sigInt :: il + +let instrTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + + +let rec splitTimeBlocks aux il = + match il with + | h::t when ((instrTimingPoint h) && List.length t <> 0) -> begin + if List.length aux > 0 then + List.append ([ mkStmt (Instr (List.rev aux)); mkStmtOneInstr h]) (splitTimeBlocks [] t) + else + List.append [mkStmtOneInstr h] (splitTimeBlocks [] t) + end + | h::t when ((instrTimingPoint h) && List.length t = 0) -> begin + if List.length aux > 0 then + List.append [mkStmt (Instr (List.rev aux))] [mkStmtOneInstr h] + else + [mkStmtOneInstr h] + end + | h::t when not (instrTimingPoint h) -> splitTimeBlocks (h :: aux) t + | [] -> [mkStmt (Instr (List.rev aux))] + +let makeTimeBlocks il = + splitTimeBlocks [] il + +class timingAnalysis filename = object(self) + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr (il) -> begin + if (List.exists instrTimingPoint il) then + let list_of_stmts = makeTimeBlocks il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + |_ -> DoChildren +end + +class sdelayReportAdder filename fdec structvar fname = object(self) + inherit nopCilVisitor + + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) +end + +class correctnessAnalysis f = object(self) + inherit nopCilVisitor + + method vfunc(fdec: fundec) = + Cfg.clearFileCFG f; + computeTPSucc fdec; + computeAvail fdec; + DoChildren +(* + method vstmt (s :stmt) = + match s.skind with + |Instr (il) -> +*) +end +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + (*Cfg.computeFileCFG filename; + Cfg.clearFileCFG filename; + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec;*) +(* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; *) + (*computeAvail fdec; *) + computeTPSucc fdec; + computeAvail fdec; + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let init_start = makeSdelayEndInstr structvar ftimer in + let modifysdelay = new sdelayReportAdder filename fdec structvar fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts; + ChangeTo(fdec) + +end + +let isErrorFree f = + let cVisitor = new correctnessAnalysis f in + visitCilFile cVisitor f + +let timing_basic_block f = + let thisVisitor = new timingAnalysis f in + visitCilFileSameGlobals thisVisitor f + + +let sdelay (f : file) : unit = + initSdelayFunctions f; timing_basic_block f; + (*Cfg.clearFileCFG f; + Cfg.computeFileCFG f; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; *) + let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f +(* +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f*) diff --git a/src/sdelay_1.ml b/src/sdelay_1.ml new file mode 100644 index 0000000..269af03 --- /dev/null +++ b/src/sdelay_1.ml @@ -0,0 +1,511 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow + + +let debug = ref false + + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "create_timer" +let sig_setjmp_str = "sigsetjmp" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; +] + +(* +type tpmap = int * (Cil.stmt * Cil.exp) + +let id_of_tm (tm : tpmap) : int = fst tm +let st_of_tm (tm : tpmap) : stmt = tm |> snd |> fst +let intr_of_tm (tm : tpmap) : Cil.exp = tm |> snd |> snd + + +let tpmap_list_pretty () (tmap : tpmap list) = + let tm = L.hd tmap in + d_exp () (intr_of_tm tm) + + + +let tpmap_equal (tm1 : tpmap) (tm2 : tpmap) : bool = + (id_of_tm tm1) = (id_of_tm tm2) && + (intr_of_tm tm1) = (intr_of_tm tm2) + +let tpmap_list_equal (tpl1 : tpmap list) (tpl2 : tpmap list) : bool = + let sort = L.sort (fun (id1,_) (id2,_) -> compare id1 id2) in + list_equal tpmap_equal (sort tpl1) (sort tpl2) + +let intr_combine intr1 intr2 : Cil.exp = + if intr1 = Cil.mone then + intr2 + else + intr1 + +let tpmap_combine (tm1 : tpmap) (tm2 : tpmap) : tpmap option = + match tm1, tm2 with + | (id1, _), (id2, _) when id1 <> id2 -> None + | (id1, (s1, k1)), (_,(_,k2)) -> Some(id1,(s1, intr_combine k1 k2)) + + +let tpmap_list_combine_one (tml : tpmap list) (tm : tpmap) : tpmap list = + let id = id_of_tm tm in + if L.mem_assoc id tml then + let tm' = (id, L.assoc id tml) in + let tm'' = forceOption (tpmap_combine tm tm') in + tm'' :: (L.remove_assoc (id_of_tm tm) tml) + else tm :: tml + + +let tpmap_list_combine (tml1 : tpmap list) (tml2 : tpmap list) : tpmap list = + L.fold_left tpmap_list_combine_one tml1 tml2 + + +let tpmap_list_replace (tml : tpmap list) (tm : tpmap) : tpmap list = + tm :: (L.remove_assoc (id_of_tm tm) tml) + + + +let isTimingPoint il = + match L.hd il with + |Call(_,Lval(Var vi,_),_,_) when (vi.vname = "sdelay") -> true + |Call(_,Lval(Var vi,_),_,_) when (vi.vname = "fdelay") -> true + |_ -> false + +let isStmTimingPoint s = + match s.skind with + |Instr il when (isTimingPoint il = true )-> true + |Instr il when (isTimingPoint il) = false -> false + | _ -> false + + +let collectTimingPoint fd = + let stmtsOfFun = fd.sallstmts in + let timingPointStm = L.filter isStmTimingPoint stmtsOfFun in + L.map (fun s -> (s.sid, (s, Cil.mone))) timingPointStm + +let timingSucc ts = + let tSucc = L.filter isStmTimingPoint ts.succs in + let sort = L.sort (fun s1 s2 -> compare s1.sid s2.sid) in + let tims = L.hd (sort tSucc) in + match tims.skind with + | Instr il -> L.hd il + |_ -> raise(Failure "Something is very wrong") + + +let tpmap_list_handle_stmt (s: stmt) (tml : tpmap list) : tpmap list = + if isStmTimingPoint s then begin + let ti = timingSucc s in + match ti with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = "fdelay") -> tpmap_list_replace tml (s.sid, (s, L.hd argList)) + | _ -> tml + end + else + tml + +module TimingPointDF = struct + + let name = "TimingPoint" + let debug = debug + type t = tpmap list + let copy tml = tml + let stmtStartData = IH.create 64 + let pretty = tpmap_list_pretty + let computeFirstPredecessor stm tml = tml + + + let combinePredecessors (s : stmt) ~(old : t) (ll : t) = + if tpmap_list_equal old ll then None else + Some(tpmap_list_combine old ll) + + let doInstr (i : instr) (ll : t) = DF.Default + + let doStmt (stm : stmt) (ll : t) = + let action = tpmap_list_handle_stmt stm ll in + DF.SUse action + + let doGuard c ll = DF.GDefault + let filterStmt stm = true + +end + + +module TimingPoint = DF.ForwardsDataFlow(TimingPointDF) + + +let computeTimingPoint (fd : fundec) : unit = + Cfg.clearCFGinfo fd; + ignore(Cfg.cfgFun fd); + let first_stmt = L.hd fd.sbody.bstmts in + let tml = collectTimingPoint fd in + IH.clear TimingPointDF.stmtStartData; + IH.add TimingPointDF.stmtStartData first_stmt.sid tml; + TimingPoint.compute [first_stmt] + +let getTimingPoints (sid: int) : tpmap list option = + try Some(IH.find TimingPointDF.stmtStartData sid) + with Not_found -> None + + +let instrTimingPoint (s ) (tml : tpmap list) : tpmap list list = + let proc_one hil s = + match hil with + | [] -> (tpmap_list_handle_stmt s tml) :: hil + | tml':: rst as l -> (tpmap_list_handle_stmt s tml') :: l + in + L.fold_left proc_one [tml] s + + +class tmlVisitorClass = object(self) + inherit nopCilVisitor + + val mutable sid = -1 + val mutable state_list = [] + val mutable current_state = None + + method vstmt stm = + sid <- stm.sid; + begin match getTimingPoints sid with + | None -> current_state <- None + | Some tml -> begin + match stm.skind with + | Instr il -> + current_state <- None; + state_list <- instrTimingPoint [stm] tml + | _ -> current_state <- None + end end; + DoChildren + + + method get_cur_tml () = + match current_state with + | None -> getTimingPoints sid + | Some tml -> Some tml + +end + +class stmntUseReporterClass = object(self) + inherit tmlVisitorClass as super + + method vstmt (s :stmt ) = + match self#get_cur_tml () with + |None -> SkipChildren + |Some tml -> begin + if L.mem_assoc s.sid tml then begin + let tm = (s.sid, L.assoc s.sid tml) in + E.log "%a: %a\n" d_loc (!currentLoc) tpmap_list_pretty [tm] + end; + SkipChildren + end + +end + + +let timingPointAnalysis (fd : fundec) : unit = + computeTimingPoint fd; + let vis = ((new stmntUseReporterClass) :> nopCilVisitor) in + ignore(visitCilFunction vis fd) +*) + + + + + + + + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) = + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let maketimerfdelayStmt loc s il fdelayIntr = + let buf = mkString "env" in + let sigInt = Call(None, v2e sdelayfuns.sig_setjmp, [buf;], loc) in + sigInt :: il + + + + + +(* +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +*) +(* +let mark sl = + match sl with + | hd::tl -> begin + match hd.skind with + |Instr il -> markTime hd il; mark tl + |_ -> mark tl + end + | _ -> mark tl + +let markTimingPoint s = + match s with + |Instr il = mark il +let addPrevTimingPoint s il timingPointList = + match L.hd il with + |Call(_,Lval(Var vi,_),_,loc) when (vi.vname = fname) -> begin + if fst L.hd timingPointList = dummyStmt then + timingPointList <- timingPointList ::(s, s.sid) + end + |_ -> timingPointList.timingPoint +*) + +(* +let mark st timingPoints id timerTime = + if st.sid > id then + st.sid + else + id +*) +(* +let findIntr s = + match s.skind with + |Instr il ->begin + match L.hd il with + |Call(_,Lval(Var vi,_),argList ,loc) when vi.vname = "fdelay" -> L.hd argList + |Call(_,Lval(Var vi,_),_,loc) when vi.vname = "sdelay" -> Cil.zero + |_ -> Cil.mone + end + |_ -> Cil.mone + +let rec addTimer s = + match s with + |h::t -> if findIntr h <> Cil.mone then + findIntr h + else addTimer t + + |[] -> Cil.zero +*) + +(* +class fdelayReportAdder filename fdec timingPointList = object(self) + inherit nopCilVisitor + method vstmt (s : stmt) = + let id = -1 in + let timingPoints = (dummyStmt, -1) in + match s.skind with + |Instr il -> begin + match L.hd il with + |Call(_,Lval(Var vi,_),argList,loc) when vi.vname = "fdelay" -> addPrevTimingPoint s s.preds timingPoints id L.hd argList; + timingPointList <- timingPoints :: timingPointList + end; DoChildren + | _ -> DoChildren +end +*) + +(* +class timerAdder filename fdec structvar timervar = object(self) + inherit nopCilVisitor + method vstmt (s ) = + Cfg.clearFileCFG filename; + Cfg.computeFileCFG filename; + let fname = "fdelay" in + let sname = "sdelay" in + let fdelayIntr = addTimer s in + let action s = + match s.skind with + |Instr il -> match L.hd il with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> if fdelayIntr <> Cil.zero then + s.skind <- Block ( maketimerfdelayStmt filename s fdelayIntr); s + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> if fdelayIntr <> Cil.zero then + s.skind <- Block (maketimerfdelayStmt filename s fdelayIntr); s + |_ -> s + in + ChangeDoChildrenPost(s, action) + +end + +*) + + +class sdelayReportAdder filename fdec structvar fname = object(self) + inherit nopCilVisitor + +(* + method vstmt (s ) = + let fname = "fdelay" in + let sname = "sdelay" in + let fdelayIntr = Cil.mone in + let action s = begin + match s.skind with + |Instr il -> begin + match L.hd il with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> begin + if fdelayIntr <> Cil.zero then + (* maketimerfdelayStmt loc s il fdelayIntr*) s.skind + end + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> begin + if fdelayIntr <> Cil.zero then + s.skind (* maketimerfdelayStmt loc s il fdelayIntr*) + end + |_ -> s.skind + end;s + |_ -> s + end + in + ChangeDoChildrenPost(s, action) +*) +(* + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) +*) +end + +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + (*Cfg.computeFileCFG filename; *) + Cfg.clearFileCFG filename; + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; +(* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; *) + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let init_start = makeSdelayEndInstr structvar ftimer in + (*let modifysdelay = new sdelayReportAdder filename fdec structvar fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; *) + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts ; timingPointAnalysis fdec; + ChangeTo(fdec) + +end + +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f diff --git a/src/sdelay_2.ml b/src/sdelay_2.ml new file mode 100644 index 0000000..5ba76a1 --- /dev/null +++ b/src/sdelay_2.ml @@ -0,0 +1,316 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow +module AV = Avail + +let debug = ref false + + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; + mutable start_timer : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; + start_timer = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "create_timer" +let sig_setjmp_str = "__sigsetjmp" +let start_timer_str = "start_timer_fdelay" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; + start_timer_str; +] + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type; + sdelayfuns.start_timer <- focf start_timer_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) (tp : varinfo)= + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let handlrt = mkAddrOf((var tp)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;handlrt;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let maketimerfdelayStmt structvar argL tpstructvar timervar= + let offset' = match tpstructvar.vtype with + | TComp (cinfo, _) -> Field (getCompField cinfo "env", NoOffset) in + let buf = Lval(Var tpstructvar, offset') in + let i = Cil.one in + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let intr, tunit, timr, s = L.hd argL, time_unit, v2e timervar, v2e structvar in + let sigInt = Call(None, v2e sdelayfuns.sig_setjmp, [buf;i;], locUnknown) in + let startTimer = Call(None, v2e sdelayfuns.start_timer, [intr; tunit;timr;s;], locUnknown) in + [mkStmtOneInstr sigInt; mkStmtOneInstr startTimer ] + +let instrTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let instrTimingPointAftr (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "ktc_sdelay_init") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "ktc_fdelay_init") -> true + | _ -> false +(* +let getFirmInterval s = + match s.kind with + |Instr il when List.hd il = Call (_, Lval (Var vf, _), argList, _) -> argList +*) +let rec splitTimeBlocks aux il = + match il with + | h::t when ((instrTimingPoint h) && List.length t <> 0) -> begin + if List.length aux > 0 then + List.append ([ mkStmt (Instr (List.rev aux)); mkStmtOneInstr h]) (splitTimeBlocks [] t) + else + List.append [mkStmtOneInstr h] (splitTimeBlocks [] t) + end + | h::t when ((instrTimingPoint h) && List.length t = 0) -> begin + if List.length aux > 0 then + List.append [mkStmt (Instr (List.rev aux))] [mkStmtOneInstr h] + else + [mkStmtOneInstr h] + end + | h::t when not (instrTimingPoint h) -> splitTimeBlocks (h :: aux) t + | [] -> [mkStmt (Instr (List.rev aux))] + +let makeTimeBlocks il = + splitTimeBlocks [] il + +class timingAnalysis filename = object(self) + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr (il) -> begin + if (List.exists instrTimingPoint il) then + let list_of_stmts = makeTimeBlocks il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + |_ -> DoChildren +end + +let getInstr s = + match s.skind with + |Instr il -> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) -> argList + +class sdelayReportAdder filename fdec structvar tpstructvar timervar data fname = object(self) + inherit nopCilVisitor + + + + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) + + method vstmt s = + let action s = + match s.skind with + Instr il -> + if instrTimingPointAftr (List.hd il) && (checkFirmSuccs data s) then + let firmSuccInst = retFirmSucc s data in + let intr = getInstr firmSuccInst in + let addthisTo = maketimerfdelayStmt structvar intr tpstructvar timervar in + let changStmTo = mkStmt s.skind :: addthisTo in + let block = mkBlock changStmTo in + s.skind <- Block block; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + + +end + + + +class correctnessAnalysis f = object(self) + inherit nopCilVisitor + + method vfunc(fdec: fundec) = + checkTPSucc fdec; + checkAvailOfStmt fdec; + DoChildren + +(* method vstmt (s :stmt) = + match s.skind with + |Instr (il) -> begin + if (List.length il = 1 && instrTimingPoint (List.hd il)) then + varAvailable s; fdelayWorks s + end; DoChildren + |_ -> DoChildren +*) +end +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; + Cfg.clearFileCFG filename; +(* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; + computeAvail fdec; + computeTPSucc fdec; + computeAvail fdec; + let data = checkTPSucc fdec in *) + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let tpstructvarinfo = findCompinfo filename "tp_struct" in + let tpstructvar = makeLocalVar fdec "tp" (TComp(tpstructvarinfo,[])) in + let init_start = makeSdelayEndInstr structvar ftimer tpstructvar in + let data = checkTPSucc fdec in + let y = checkAvailOfStmt fdec in + let modifysdelay = new sdelayReportAdder filename fdec structvar tpstructvar ftimer data fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts; + ChangeTo(fdec) + +end +let isErrorFree f = + let cVisitor = new correctnessAnalysis f in + visitCilFile cVisitor f + +let timing_basic_block f = + let thisVisitor = new timingAnalysis f in + visitCilFileSameGlobals thisVisitor f + + +let sdelay (f : file) : unit = +initSdelayFunctions f; timing_basic_block f; (*isErrorFree f;*) +let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f +(* +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f*) diff --git a/src/sdelay_3.ml b/src/sdelay_3.ml new file mode 100644 index 0000000..7ed908f --- /dev/null +++ b/src/sdelay_3.ml @@ -0,0 +1,344 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow +module AV = Avail + +let debug = ref false +let labelHash = IH.create 64 + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; + mutable start_timer : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; + start_timer = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "create_timer" +let sig_setjmp_str = "__sigsetjmp" +let start_timer_str = "start_timer_fdelay" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; + start_timer_str; +] + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type; + sdelayfuns.start_timer <- focf start_timer_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) (tp : varinfo)= + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let handlrt = mkAddrOf((var tp)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;handlrt;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let ifBlockFunc goto_stmt retjmp = + goto_stmt.skind <- Goto(ref goto_stmt, locUnknown); + let block_goto = mkBlock[goto_stmt] in + let block_else = mkBlock[] in + let ifcond = If((v2e retjmp), block_goto, block_else, locUnknown) in + (mkStmt ifcond) + +let findgoto data s = + try IH.find data s.sid + with Not_found -> E.s(E.bug "%d jgd" s.sid) + + +let maketimerfdelayStmt structvar argL tpstructvar timervar retjmp firmStmt = + let offset' = match tpstructvar.vtype with + | TComp (cinfo, _) -> Field (getCompField cinfo "env", NoOffset) in + let buf = Lval(Var tpstructvar, offset') in + let i = Cil.one in + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let intr, tunit, timr, s = L.hd argL, time_unit, v2e timervar, v2e structvar in + let sigInt = Call(Some(var retjmp), v2e sdelayfuns.sig_setjmp, [buf;i;], locUnknown) in + let letjmpto = findgoto labelHash firmStmt in + let goto_label = mkStmt (Goto(ref letjmpto, locUnknown)) in + let ifBlock = ifBlockFunc goto_label retjmp in + let startTimer = Call(None, v2e sdelayfuns.start_timer, [intr; tunit;timr;s;], locUnknown) in + [mkStmtOneInstr sigInt; ifBlock; mkStmtOneInstr startTimer ] + +let instrTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let instrTimingPointAftr (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "ktc_sdelay_init") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "ktc_fdelay_init") -> true + | _ -> false +(* +let getFirmInterval s = + match s.kind with + |Instr il when List.hd il = Call (_, Lval (Var vf, _), argList, _) -> argList +*) +let rec splitTimeBlocks aux il = + match il with + | h::t when ((instrTimingPoint h) && List.length t <> 0) -> begin + if List.length aux > 0 then + List.append ([ mkStmt (Instr (List.rev aux)); mkStmtOneInstr h]) (splitTimeBlocks [] t) + else + List.append [mkStmtOneInstr h] (splitTimeBlocks [] t) + end + | h::t when ((instrTimingPoint h) && List.length t = 0) -> begin + if List.length aux > 0 then + List.append [mkStmt (Instr (List.rev aux))] [mkStmtOneInstr h] + else + [mkStmtOneInstr h] + end + | h::t when not (instrTimingPoint h) -> splitTimeBlocks (h :: aux) t + | [] -> [mkStmt (Instr (List.rev aux))] + +let makeTimeBlocks il = + splitTimeBlocks [] il + +class timingAnalysis filename = object(self) + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr (il) -> begin + if (List.exists instrTimingPoint il) then + let list_of_stmts = makeTimeBlocks il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + |_ -> DoChildren +end + +let getInstr s = + match s.skind with + |Instr il when il <> []-> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) -> argList + +class sdelayReportAdder filename fdec structvar tpstructvar timervar ret_jmp data fname = object(self) + inherit nopCilVisitor + + + + + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) + + method vstmt s = + let tname = E.log "out here fdelay" in + let action s = + match s.skind with + Instr il when il <> [] -> if instrTimingPointAftr (List.hd il) && (checkFirmSuccs data s) then + (*let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(string_to_int s.sid,locUnknown,false)] ;*) + let tname = E.log "out here fdelay" in + let firmSuccInst = retFirmSucc s data in + let intr = getInstr firmSuccInst in + let addthisTo = maketimerfdelayStmt structvar intr tpstructvar timervar ret_jmp firmSuccInst in + let changStmTo = (mkStmt s.skind) :: addthisTo in + let block = mkBlock changStmTo in + s.skind <- Block block; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + + +end + +class correctnessAnalysis fdec = object(self) + inherit nopCilVisitor + method vstmt (s :stmt) = + let action s = + match s.skind with + |Instr (il) -> + if (List.length il = 1 && instrTimingPoint (List.hd il)) && (isFirm (List.hd il)) then + let label_no = s.sid + 2 in + let label_name = "_"^string_of_int(label_no) in + let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(label_name,locUnknown,false)]; E.log "%d" label_no; IH.add labelHash label_no label_stmt; + let changStmTo = [label_stmt; mkStmt s.skind] in + let block = mkBlock changStmTo in + s.skind <- Block block ; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + +end + +let isErrorFree f = + IH.clear labelHash; E.log "jgd-jgd-jgd iserroefree" ; + let cVisitor = new correctnessAnalysis f in + visitCilFile cVisitor f + + +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; + Cfg.clearFileCFG filename; + (* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; + computeAvail fdec; + computeTPSucc fdec; + computeAvail fdec; + let data = checkTPSucc fdec in *) + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let tpstructvarinfo = findCompinfo filename "tp_struct" in + let tpstructvar = makeLocalVar fdec "tp" (TComp(tpstructvarinfo,[])) in + let ret_jmp = makeLocalVar fdec "retjmp" intType in + let init_start = makeSdelayEndInstr structvar ftimer tpstructvar in + let data = checkTPSucc fdec in + let y = checkAvailOfStmt fdec in + (*let y' = isErrorFree filename in*) + let modifysdelay = new sdelayReportAdder filename fdec structvar tpstructvar ftimer ret_jmp data fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts; + ChangeTo(fdec) + +end + +let timing_basic_block f = + let thisVisitor = new timingAnalysis f in + visitCilFileSameGlobals thisVisitor f + + +let sdelay (f : file) : unit = +initSdelayFunctions f; Cfg.computeFileCFG f;isErrorFree f; Cfg.clearFileCFG f; timing_basic_block f; +let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f +(* +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f*) diff --git a/src/sdelay_4.ml b/src/sdelay_4.ml new file mode 100644 index 0000000..997823f --- /dev/null +++ b/src/sdelay_4.ml @@ -0,0 +1,353 @@ +open Cil +open Pretty +open Ktcutil + +module E = Errormsg +module L = List + +module IH = Inthash +module DF = Dataflow +module AV = Avail + +let debug = ref false +let labelHash = IH.create 64 + +let findOrCreateFunc f name t = + let rec search glist = + match glist with + GVarDecl(vi,_) :: rest when isFunctionType vi.vtype + && vi.vname = name -> vi + | _ :: rest -> search rest (* tail recursive *) + | [] -> (*not found, so create one *) + let new_decl = makeGlobalVar name t in + f.globals <- GVarDecl(new_decl, locUnknown) :: f.globals; + new_decl + in + search f.globals + + + +let findStructType (f : file) (typname : string) : typ = + let rec search gl = + match gl with + | [] -> E.s (E.error "Type not found: %s" typname) + | GCompTag(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | GCompTagDecl(ci,_) :: _ when ci.cname = typname -> TComp(ci,[]) + | _ :: rest -> search rest + in + search f.globals + + +let findCompinfo (f : file) (ciname : string) : compinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Compinfo not found") + | GCompTag(ci, _) :: _ when ci.cname = ciname -> ci + | GCompTagDecl(ci, _) :: _ when ci.cname = ciname -> ci + | _ :: rest -> search rest + in + search f.globals + +let findTypeinfo (f : file) (tpname : string) : typeinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "typeinfo not found") + | GType(tp, _) :: _ when tp.tname = tpname -> tp + | _ :: rest -> search rest + in + search f.globals + +let findVarG (f : file) (viname : string) : varinfo = + let rec search glist = + match glist with + | [] -> raise(Failure "Var not found") + | GVarDecl(vi, _) :: _ when vi.vname = viname -> vi + | _ :: rest -> search rest + in + search f.globals + +type functions = { + mutable sdelay_init : varinfo; + mutable sdelay_end : varinfo; + mutable fdelay_init :varinfo; + mutable timer_create : varinfo; + mutable sig_setjmp : varinfo; + mutable start_timer : varinfo; +} + +let dummyVar = makeVarinfo false "_sdelay_foo" voidType + +let sdelayfuns = { + sdelay_init = dummyVar; + sdelay_end = dummyVar; + fdelay_init = dummyVar; + timer_create = dummyVar; + sig_setjmp = dummyVar; + start_timer = dummyVar; +} + + + +let sdelay_init_str = "ktc_sdelay_init" +let sdelay_end_str = "ktc_start_time_init" +let fdelay_init_str = "ktc_fdelay_init" +let timer_create_str = "create_timer" +let sig_setjmp_str = "__sigsetjmp" +let start_timer_str = "start_timer_fdelay" + +let sdelay_function_names = [ + sdelay_init_str; + sdelay_end_str; + fdelay_init_str; + timer_create_str; + sig_setjmp_str; + start_timer_str; +] + + +let isSdelayFun (name : string) : bool = + L.mem name sdelay_function_names + +let initSdelayFunctions (f : file) : unit = + let focf : string -> typ -> varinfo = findOrCreateFunc f in + let init_type = TFun(intType, Some["unit", charPtrType, [];], + false, []) + in + let end_type = TFun(intType, Some["intrval", intType, [];], + false, []) + in + sdelayfuns.sdelay_init <- focf sdelay_init_str init_type; + sdelayfuns.sdelay_end <- focf sdelay_end_str end_type; + sdelayfuns.fdelay_init <- focf fdelay_init_str init_type; + sdelayfuns.timer_create <- focf timer_create_str init_type; + sdelayfuns.sig_setjmp <- focf sig_setjmp_str init_type; + sdelayfuns.start_timer <- focf start_timer_str init_type + + +let makeSdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.sdelay_init, [intervl;tunit;s;], loc)] + +let makeSdelayEndInstr (structvar : varinfo) (timervar : varinfo) (tp : varinfo)= + let s = mkAddrOf((var structvar)) in + let start_time_init = Call(None, v2e sdelayfuns.sdelay_end, [s;], locUnknown) in + let t = mkAddrOf((var timervar)) in + let handlrt = mkAddrOf((var tp)) in + let timer_init = Call(None, v2e sdelayfuns.timer_create, [t;handlrt;], locUnknown) in + [mkStmtOneInstr start_time_init; mkStmtOneInstr timer_init] + +let makeFdelayInitInstr (structvar : varinfo) (argL : exp list) (loc : location) : instr list = + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let f, l, intervl, tunit, s = mkString loc.file, integer loc.line, L.hd argL, time_unit, mkAddrOf((var structvar)) in + [Call(None,v2e sdelayfuns.fdelay_init, [intervl;tunit;s;], loc)] + +let ifBlockFunc goto_stmt retjmp = + (*goto_stmt.skind <- Goto(ref goto_stmt, locUnknown);*) + let block_goto = mkBlock[goto_stmt] in + let block_else = mkBlock[] in + let ifcond = If((v2e retjmp), block_goto, block_else, locUnknown) in + (mkStmt ifcond) + + + +let getvaridStmt s = + match s.skind with + |Instr il when il <> []-> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = "fdelay") -> vi.vid + |_ -> E.s(E.bug "Error: label"); -1 + +let findgoto data s = + let id = getvaridStmt s in + try IH.find data id + with Not_found -> E.s(E.bug "%d" id) + +let maketimerfdelayStmt structvar argL tpstructvar timervar retjmp firmStmt = + let offset' = match tpstructvar.vtype with + | TComp (cinfo, _) -> Field (getCompField cinfo "env", NoOffset) in + let buf = Lval(Var tpstructvar, offset') in + let i = Cil.one in + let time_unit = if (L.length argL) = 1 then mkString "NULL" else L.hd (L.tl argL) in + let intr, tunit, timr, s = L.hd argL, time_unit, v2e timervar, v2e structvar in + let sigInt = Call(Some(var retjmp), v2e sdelayfuns.sig_setjmp, [buf;i;], locUnknown) in + let letjmpto = findgoto labelHash firmStmt in + let goto_label = mkStmt (Goto(ref letjmpto, locUnknown)) in + let ifBlock = ifBlockFunc goto_label retjmp in + let startTimer = Call(None, v2e sdelayfuns.start_timer, [intr; tunit;timr;s;], locUnknown) in + [mkStmtOneInstr sigInt; ifBlock; mkStmtOneInstr startTimer ] + +let instrTimingPoint (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "fdelay") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "sdelay") -> true + | _ -> false + +let instrTimingPointAftr (i : instr) : bool = + match i with + | Call (_, Lval (Var vf, _), _, _) when (vf.vname = "ktc_sdelay_init") -> true + | Call (_, Lval(Var vf,_), _, _) when (vf.vname = "ktc_fdelay_init") -> true + | _ -> false +(* +let getFirmInterval s = + match s.kind with + |Instr il when List.hd il = Call (_, Lval (Var vf, _), argList, _) -> argList +*) +let rec splitTimeBlocks aux il = + match il with + | h::t when ((instrTimingPoint h) && List.length t <> 0) -> begin + if List.length aux > 0 then + List.append ([ mkStmt (Instr (List.rev aux)); mkStmtOneInstr h]) (splitTimeBlocks [] t) + else + List.append [mkStmtOneInstr h] (splitTimeBlocks [] t) + end + | h::t when ((instrTimingPoint h) && List.length t = 0) -> begin + if List.length aux > 0 then + List.append [mkStmt (Instr (List.rev aux))] [mkStmtOneInstr h] + else + [mkStmtOneInstr h] + end + | h::t when not (instrTimingPoint h) -> splitTimeBlocks (h :: aux) t + | [] -> [mkStmt (Instr (List.rev aux))] + +let makeTimeBlocks il = + splitTimeBlocks [] il + +class timingAnalysis filename = object(self) + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr (il) -> begin + if (List.exists instrTimingPoint il) then + let list_of_stmts = makeTimeBlocks il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + |_ -> DoChildren +end + +let getInstr s = + match s.skind with + |Instr il when il <> []-> match List.hd il with + |Call(_,Lval(Var vi,_),argList,loc) -> argList + +class sdelayReportAdder filename fdec structvar tpstructvar timervar ret_jmp data fname = object(self) + inherit nopCilVisitor + + + + + method vinst (i :instr) = + let sname = "fdelay" in + let action [i] = + match i with + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = fname) -> makeSdelayInitInstr structvar argList loc + |Call(_,Lval(Var vi,_),argList,loc) when (vi.vname = sname) -> makeFdelayInitInstr structvar argList loc + |_ -> [i] + in + ChangeDoChildrenPost([i], action) + + method vstmt s = + let action s = + match s.skind with + Instr il when il <> [] -> if instrTimingPointAftr (List.hd il) && (checkFirmSuccs data s) then + (*let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(string_to_int s.sid,locUnknown,false)] ;*) + (*let tname = E.log "out here fdelay" in*) + let firmSuccInst = retFirmSucc s data in + let intr = getInstr firmSuccInst in + let addthisTo = maketimerfdelayStmt structvar intr tpstructvar timervar ret_jmp firmSuccInst in + let changStmTo = (mkStmt s.skind) :: addthisTo in + let block = mkBlock changStmTo in + s.skind <- Block block; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + + +end + + + +class correctnessAnalysis fdec = object(self) + inherit nopCilVisitor + method vstmt (s :stmt) = + let action s = + match s.skind with + |Instr (il) -> + if (List.length il = 1 && instrTimingPoint (List.hd il)) && (isFirm (List.hd il)) then + let label_name = "_"^string_of_int(s.sid) in + let label_no = getvaridStmt s in + let label_stmt = mkStmt (Instr []) in + label_stmt.labels <- [Label(label_name,locUnknown,false)]; (*E.log "%d" label_no;*) IH.add labelHash label_no label_stmt; + let changStmTo = List.append [mkStmt s.skind] [label_stmt] in + let block = mkBlock changStmTo in + s.skind <- Block block ; + s + else + s + + |_ -> s + in ChangeDoChildrenPost(s, action) + +end + +let isErrorFree f = + IH.clear labelHash; (*E.log "jgd-jgd-jgd iserroefree";*) + let cVisitor = new correctnessAnalysis f in + visitCilFile cVisitor f + + +class sdelayFunc filename fname = object(self) + inherit nopCilVisitor + + method vfunc (fdec : fundec) = + Cfg.computeFileCFG filename; + Cfg.printCfgFilename (fdec.svar.vname ^ ".dot") fdec; + Cfg.clearFileCFG filename; + (* Cfg.cfgFunPrint (fdec.svar.vname^".dot") fdec; + computeAvail fdec; + computeTPSucc fdec; + computeAvail fdec; + let data = checkTPSucc fdec in *) + let timername = "timer_t" in + let ftimer = findTypeinfo filename timername in + let ftimer = makeLocalVar fdec "ktctimer" (TNamed(ftimer, [])) in + let structname = "timespec" in + let ci = findCompinfo filename structname in + let structvar = makeLocalVar fdec "start_time" (TComp(ci,[])) in + let tpstructvarinfo = findCompinfo filename "tp_struct" in + let tpstructvar = makeLocalVar fdec "tp" (TComp(tpstructvarinfo,[])) in + let ret_jmp = makeLocalVar fdec "retjmp" intType in + let init_start = makeSdelayEndInstr structvar ftimer tpstructvar in + let data = checkTPSucc fdec in + let y = checkAvailOfStmt fdec in + (*let y' = isErrorFree filename in*) + let modifysdelay = new sdelayReportAdder filename fdec structvar tpstructvar ftimer ret_jmp data fname in + fdec.sbody <- visitCilBlock modifysdelay fdec.sbody; + fdec.sbody.bstmts <- List.append init_start fdec.sbody.bstmts; + ChangeTo(fdec) + +end + +let timing_basic_block f = + let thisVisitor = new timingAnalysis f in + visitCilFileSameGlobals thisVisitor f + + +let sdelay (f : file) : unit = +initSdelayFunctions f; timing_basic_block f; Cfg.computeFileCFG f;isErrorFree f; Cfg.clearFileCFG f; +let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f +(* +let sdelay (f : file) : unit = + initSdelayFunctions f; Ciltools.one_instruction_per_statement f ; let fname = "sdelay" in + let vis = new sdelayFunc f fname in + visitCilFile vis f*) diff --git a/test/demo1.c b/test/demo1.c new file mode 100644 index 0000000..8b0872d --- /dev/null +++ b/test/demo1.c @@ -0,0 +1,14 @@ +#include +#include + + +int main(){ + sdelay(0); + sleep(1); + sdelay(2, "ms"); + sleep(1); + fdelay(2, "ms"); + return 1; + +} + diff --git a/test/demo2.c b/test/demo2.c new file mode 100644 index 0000000..c9fafeb --- /dev/null +++ b/test/demo2.c @@ -0,0 +1,13 @@ +#include +#include +/*Available Var - Not available due if cond*/ + +int main(){ + int a, b; + sdelay(0); + if(a>10) + b = 10; + sdelay(b, "ms"); + +} + diff --git a/test/demo3.c b/test/demo3.c new file mode 100644 index 0000000..6ad0de6 --- /dev/null +++ b/test/demo3.c @@ -0,0 +1,17 @@ +#include +#include +/*Available Var - available due if cond*/ + +int main(){ + int a, b; + sdelay(0); + a = 10; + if(a> 10){ + fdelay(3, "ms"); + } + else + fdelay(4, "ms"); + sdelay(b, "ms"); + +} + diff --git a/test/demo4.c b/test/demo4.c new file mode 100644 index 0000000..ead7363 --- /dev/null +++ b/test/demo4.c @@ -0,0 +1,15 @@ +#include +#include +/*Available Var - not available due to while` cond*/ + +int main(){ + int a, b; + sdelay(0); + a = 10; + while(a){ + b =10; + } + sdelay(b, "ms"); + +} + diff --git a/test/demo5.c b/test/demo5.c new file mode 100644 index 0000000..856ecae --- /dev/null +++ b/test/demo5.c @@ -0,0 +1,16 @@ +#include +#include +/*Available Var -available inside if*/ + +int main(){ + int a, b; + sdelay(0); + a = 10; + b = 16; + if(a) + sdelay(b, "ms"); + else + fdelay(a, "ms"); + +} + diff --git a/test/demo6.c b/test/demo6.c new file mode 100644 index 0000000..42299dd --- /dev/null +++ b/test/demo6.c @@ -0,0 +1,17 @@ +#include +#include +/*Available Var - not available due to while` cond*/ + +int main(){ + int a, b; + sdelay(0); + a = 10; + b = 16; + if(a) + fdelay(b, "ms"); + else + sdelay(a, "ms"); + fdelay(10, "ms"); + +} + diff --git a/test/demo7.c b/test/demo7.c new file mode 100644 index 0000000..305ff9c --- /dev/null +++ b/test/demo7.c @@ -0,0 +1,17 @@ +#include +#include +/*Available Var -available inside if*/ + +int main(){ + int a, b; + sdelay(0); + a = 10; + b = 16; + if(a) + sdelay(b, "ms"); + else + fdelay(a, "ms"); + fdelay(10, "ms"); + +} + diff --git a/test/hello.c b/test/hello.c new file mode 100644 index 0000000..329a0a7 --- /dev/null +++ b/test/hello.c @@ -0,0 +1,49 @@ +#include +#include + +void sensor(){ + + int num; + struct timespec ts; + ts.tv_sec = 1; + ts.tv_nsec = 5000000 ; + srand(time(NULL)); + num = rand(); + if(num % 2 == 0){ + nanosleep(&ts, NULL); + } +} +void controller(){ + setjmp(env); + +} +void actuator(){} + + +int main(){ + + struct timespec base_time, print_time; + + int count = 0; + sdelay(0); + while(1){ + /*test*/ + count ++; + if(count == 1){ + clock_gettime(CLOCK_REALTIME, &print_time); + base_time = print_time; + + } + print_time = diff_timespec(print_time, base_time); + printf("Start Instance %d at %d secs and %lu ns\n", count, print_time.tv_sec, print_time.tv_nsec); + /*test*/ + sensor(); + controller(); + actuator(); + if(sdelay(1)){ + printf("Deadline Miss\n"); + } + (void) clock_gettime(CLOCK_REALTIME, &print_time); //testing + } + return 0; +} diff --git a/test/sd.c b/test/sd.c new file mode 100644 index 0000000..2ce5462 --- /dev/null +++ b/test/sd.c @@ -0,0 +1,51 @@ +#include +#include + +int callme(){ + int x; + x = 10; + sdelay(x); + return 1; +} + +int main(){ +/* int a, b; + sdelay(1); + a = 10; + if(a>b){ + b = 10; + fdelay(2); + } + else + fdelay(3); + b =11; + while( a-b > b) + fdelay(2); + return 1; + int a, b, c; + a = 0; + c = 10 -a ; + sdelay(0); + if(c > 1){ + sdelay(0); + b = callme1(); + } + fdelay(0); + + */ +/* int a; + callme(); + sdelay(0); + if(a){ + a = 1; + fdelay(0); + } + else + sdelay(0); + fdelay(0); + return 1;*/ + sdelay(0); + callme(); + fdelay(0); +} + diff --git a/test/sd1.c b/test/sd1.c new file mode 100644 index 0000000..0de3042 --- /dev/null +++ b/test/sd1.c @@ -0,0 +1,12 @@ +#include +#include + + +int main(){ + return 1; +} + +int callme(){ + return 1; +} +