eta 4 months ago
parent
commit
6805d3cd2f
  1. 2
      conf/conf.c
  2. 4
      configure.ac
  3. 143
      ecl/clbird.lisp
  4. 3
      ecl/cldefs.h
  5. 182
      ecl/ecl.c
  6. 23
      filter/filter.c

2
conf/conf.c

@ -280,7 +280,7 @@ config_do_commit(struct config *c, int type)
protos_commit(c, old_config, force_restart, type);
DBG("lisp\n");
if (c->lisp_load) {
clbird_load(c->lisp_load);
clbird_load_and_byte_compile(c->lisp_load);
}
int obs = 0;

4
configure.ac

@ -147,7 +147,7 @@ if test "$enable_pthreads" != no ; then
fi
# This is assumed to be necessary for proper BIRD build
CFLAGS="$CFLAGS -fno-strict-aliasing -fno-strict-overflow"
CFLAGS="$CFLAGS -fno-strict-aliasing -fno-strict-overflow -Wl,--wrap=GC_malloc"
if test "$bird_cflags_default" = yes ; then
BIRD_CHECK_GCC_OPTION([bird_cv_c_option_wno_pointer_sign], [-Wno-pointer-sign], [-Wall])
@ -184,7 +184,7 @@ ECLLDFLAGS=`ecl-config --ldflags`
AC_MSG_RESULT([$ECLLDFLAGS])
CFLAGS="$CFLAGS $ECLCFLAGS"
LDFLAGS="$LDFLAGS $ECLLDFLAGS"
LDFLAGS="$LDFLAGS $ECLLDFLAGS -Wl,--wrap=GC_malloc"
AC_MSG_CHECKING([CFLAGS])
AC_MSG_RESULT([$CFLAGS])

143
ecl/clbird.lisp

@ -50,10 +50,34 @@
:ptr ptr))
(defclass val-pair (bird-val) ())
(defmethod make-load-form ((self val-pair) &optional env)
(declare (ignore env))
(let ((pair (bird-impl::unmake-pair (slot-value self 'ptr))))
`(bird::make-pair ,(car pair) ,(cdr pair))))
(defclass val-quad (bird-val) ())
(defmethod make-load-form ((self val-quad) &optional env)
(declare (ignore env))
(let ((quad (bird-impl::unmake-quad (slot-value self 'ptr))))
`(bird::make-quad-int ,quad)))
(defclass val-ip (bird-val) ())
(defclass val-net (bird-val) ())
(defmethod make-load-form ((self val-net) &optional env)
(declare (ignore env))
(let* ((ret (bird-impl::uncidr4 (slot-value self 'ptr)))
(addr (car ret))
(o1 (ash addr -24))
(o2 (logand (ash addr -16) #xFF))
(o3 (logand (ash addr -8) #xFF))
(o4 (logand addr #xFF))
(pxlen (cdr ret)))
`(bird::cidr4 ,o1 ,o2 ,o3 ,o4 ,pxlen)))
(defun bird-type-id-to-class (id)
"Returns a symbol for the given BIRD type ID. See filter/data.h."
(declare (fixnum id))
@ -79,22 +103,78 @@
(make-bird-val obj)
obj))
(defun make-pair (cell)
(defun make-pair (int1 int2)
"Make a VAL-PAIR from a cons CELL."
(make-bird-val (bird-impl::make-val cell)))
(make-bird-val (bird-impl::make-pair int1 int2)))
(defun make-quad-int (int)
"Make a VAL-QUAD from a raw integer."
(make-bird-val (bird-impl::make-quad int)))
(defun make-quad-octets (&rest octets)
"Make a VAL-QUAD from a list of four OCTETS."
(make-bird-val (bird-impl::make-val octets)))
(defun cidr4 (o1 o2 o3 o4 prefix-len)
"Make a VAL-NET from 4 octets and a prefix length (i.e. o1.o2.o3.o4/prefix-len)"
(make-bird-val (bird-impl::cidr4 o1 o2 o3 o4 prefix-len)))
(defparameter +left-sq-bracket+ #\[)
(defparameter +right-sq-bracket+ #\])
(defparameter +full-stop+ #\.)
(defparameter +slash+ #\/)
(defparameter +comma+ #\,)
(defparameter +left-paren+ #\()
(defparameter +right-paren+ #\))
(defun read-cidr (state &optional (stream *standard-input*))
"Read a dotted quad or CIDR thing from STREAM."
(flet ((peek () (peek-char t stream t nil t))
(discard () (read-char stream t nil t)))
(let ((next (peek))
obj)
(if (char= next +right-sq-bracket+)
(progn
(discard)
state)
(progn
(setf obj (read stream t nil t))
(setf next (peek))
(cond
((char= next +full-stop+) (discard))
((char= next +comma+) (discard))
((char= next +slash+) (discard))
((char= next +right-sq-bracket+) nil)
(t (error "Unexpected ~A in CIDR notation" next)))
(unless (typep obj '(fixnum 0 256))
(error "Invalid object ~A in CIDR notation" obj))
(read-cidr (cons obj state) stream))))))
(defun read-separator (stream char)
(declare (ignore stream char))
(error "Separator character shouldn't ever be read"))
(defun sharp-left-bracket (stream char n)
"Sharpsign reader macro for #["
(declare (ignore char n))
(let ((*readtable* (copy-readtable)))
(set-macro-character +full-stop+ #'read-separator)
(set-macro-character +slash+ #'read-separator)
(set-macro-character +left-sq-bracket+ #'read-separator)
(set-macro-character +right-sq-bracket+ #'read-separator)
(let ((cidr (nreverse (read-cidr nil stream))))
(cond
((eql (length cidr) 2)
(apply #'bird::make-pair cidr))
((eql (length cidr) 4)
(bird::make-quad-int
(+
(ash (elt cidr 0) 24)
(ash (elt cidr 1) 16)
(ash (elt cidr 2) 8)
(elt cidr 3))))
((eql (length cidr) 5)
(apply #'bird::cidr4 cidr))
(t
(error "Invalid CIDR: ~A" cidr))))))
(set-dispatch-macro-character #\# #\[ #'sharp-left-bracket)
(defun bird-equal (val1 val2)
"Returns T if VAL1 is the same thing as VAL2 (both BIRD-VALs)."
(check-type val1 bird-val)
@ -115,7 +195,7 @@
(defun val>= (val1 val2) (member (bird-compare val1 val2) '(0 1)))
(defun val<= (val1 val2) (member (bird-compare val1 val2) '(0 -1)))
(defun val~ (val1 val2)
(defun ~ (val1 val2)
"Returns T if VAL1 is in the range VAL2 (both BIRD-VALs)."
(when (and val1 val2)
(check-type val1 bird-val)
@ -270,6 +350,39 @@
(gethash id +ea-code-to-keyword+ :unknown)
(maybe-make-bird-val val))))
(defun route-eattr (route id)
"Get the extended attribute with id ID for ROUTE."
(check-type route bird-route)
(maybe-make-bird-val (bird-impl::route-eattr (slot-value route 'ptr) id)))
(defparameter *route* nil)
(defun sharp-exclamation (stream char n)
(declare (ignore char n))
(let ((sym (read stream t nil t))
(eattr-id))
(unless (typep sym 'symbol)
(error "Invalid #! target ~A" sym))
(setf sym (intern (symbol-name sym) :keyword))
(unless (setf eattr-id (gethash sym +ea-keyword-to-code+))
(error "Routes do not have an extended attribute ~A (maybe try #? syntax?)" sym))
`(bird::route-eattr bird::*route* ,eattr-id)))
(set-dispatch-macro-character #\# #\! #'sharp-exclamation)
(defun sharp-question (stream char n)
(declare (ignore char n))
(let ((sym (read stream t nil t)))
(unless (typep sym 'symbol)
(error "Invalid #? target ~A" sym))
(setf sym (intern (symbol-name sym) :keyword))
(unless (member sym '(:from :gw :net :proto :source :scope
:dest :ifname :ifindex :weight))
(error "Routes do not have an attribute ~A (maybe try #! syntax?)" sym))
`(bird::route-attr bird::*route* ,sym)))
(set-dispatch-macro-character #\# #\? #'sharp-question)
(defmacro deffilter (name (route-name) &body body)
"Define a BIRD filter called NAME, with syntax similar to DEFUN. The route passed in as ROUTE-NAME is a BIRD-ROUTE object."
(let ((name-sym (intern (symbol-name name) 'bird-filter))
@ -277,13 +390,11 @@
(rte-sym (gensym)))
`(let ((,rte-csym nil))
(defun ,name-sym (,rte-sym)
(let ((,route-name (if ,rte-csym
(progn
(setf (slot-value ,rte-csym 'bird::ptr) ,rte-sym)
,rte-csym)
(setf ,rte-csym (bird::make-route ,rte-sym)))))
(let* ((,route-name (if ,rte-csym
(progn
(setf (slot-value ,rte-csym 'bird::ptr) ,rte-sym)
,rte-csym)
(setf ,rte-csym (bird::make-route ,rte-sym))))
(bird::*route* ,route-name))
(block nil
,@body))))))
(eval-when (:load-toplevel)
(format t "CL bird stuff is going brr!~%"))

3
ecl/cldefs.h

@ -16,6 +16,8 @@
// from libclbird.a
extern void clbird_native_lisp_init(cl_object);
void *clbird_alloc(size_t);
cl_object clbird_version(void);
cl_object clbird_hostname(void);
cl_object clbird_router_id(void);
@ -41,5 +43,6 @@ void init_ecl_functions(void);
void clbird_init(int, char**);
char* ecl_get_string_for(cl_object obj);
void clbird_load(char*);
void clbird_load_and_byte_compile(char*);
#endif

182
ecl/ecl.c

@ -23,6 +23,22 @@
#include "filter/data.h"
#include "cldefs.h"
void* clbird_val_alloc_space = NULL;
void *
clbird_alloc(size_t amount)
{
if (clbird_val_alloc_space == NULL) {
return ecl_alloc(amount);
}
else {
// this isn't cursed at all!
void* ptr = clbird_val_alloc_space;
clbird_val_alloc_space += amount;
return ptr;
}
}
cl_object
clbird_version()
{
@ -59,7 +75,7 @@ cl_object
clbird_get_val(cl_object which, cl_object rte_obj)
{
struct rte *rte = ecl_foreign_data_pointer_safe(rte_obj);
struct f_val *res = ecl_alloc(sizeof(struct f_val));
struct f_val *res = clbird_alloc(sizeof(struct f_val));
struct rta *rta = rte->attrs;
cl_object ret = NULL;
@ -156,16 +172,16 @@ cl_object
clbird_for_table_routes_all(cl_object table_obj, cl_object func_obj)
{
rtable *table = ecl_foreign_data_pointer_safe(table_obj);
cl_object v = eclk("VOID");
cl_object v = eclk("VOID");
FIB_WALK(&table->fib, net, n)
{
for (rte *e = n->routes; e; e = e->next) {
union cl_lispunion rte_obj;
rte_obj.d.t = t_foreign;
rte_obj.foreign.tag = v;
rte_obj.foreign.size = 0;
rte_obj.foreign.data = e;
cl_funcall(2, func_obj, &rte_obj);
union cl_lispunion rte_obj;
rte_obj.d.t = t_foreign;
rte_obj.foreign.tag = v;
rte_obj.foreign.size = 0;
rte_obj.foreign.data = e;
cl_funcall(2, func_obj, &rte_obj);
}
}
FIB_WALK_END;
@ -191,16 +207,6 @@ clbird_get_table_routes_net(cl_object table_obj, cl_object net_obj)
return ret;
}
cl_object
clbird_dotquad(cl_object o1, cl_object o2, cl_object o3, cl_object o4)
{
cl_fixnum ret = 0;
ret |= ecl_to_fix(o1) << 24;
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
return ecl_make_fixnum(ret);
}
cl_object
clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object len)
{
cl_fixnum ret = 0;
@ -208,14 +214,65 @@ clbird_cidr4(cl_object o1, cl_object o2, cl_object o3, cl_object o4, cl_object l
ret |= ecl_to_fix(o2) << 16;
ret |= ecl_to_fix(o3) << 8;
ret |= ecl_to_fix(o4);
net_addr *na = ecl_alloc(sizeof(net_addr));
net_addr *na = clbird_alloc(sizeof(net_addr));
net_fill_ip4(na, _MI4(ret), ecl_to_fix(len));
struct f_val *res = ecl_alloc(sizeof(struct f_val));
struct f_val *res = clbird_alloc(sizeof(struct f_val));
res->type = T_NET;
res->val.net = na;
return ecl_make_pointer(res);
}
cl_object
clbird_uncidr4(cl_object net_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(net_obj);
if (val->type != T_NET) {
FEerror("Can't UNCIDR4 a ~A", 1, eclcs(f_type_name(val->type)));
}
if (val->val.net->type != NET_IP4) {
FEerror("Can only UNCIDR4 an IPv4 address.", 0);
}
net_addr_ip4 *na = (net_addr_ip4 *) val->val.net;
cl_fixnum pxlen = na->pxlen;
cl_fixnum addr = _I(na->prefix);
return ecl_cons(ecl_make_fixnum(addr), ecl_make_fixnum(pxlen));
}
cl_object
clbird_make_pair(cl_object p1, cl_object p2)
{
struct f_val *res = clbird_alloc(sizeof(struct f_val));
res->type = T_PAIR;
res->val.i = ecl_to_fix(p1) << 16 | ecl_to_fix(p2);
return ecl_make_pointer(res);
}
cl_object
clbird_unmake_pair(cl_object pair_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(pair_obj);
if (val->type != T_PAIR) {
FEerror("Can't UNMAKE-PAIR a ~A", 1, eclcs(f_type_name(val->type)));
}
cl_fixnum pair = val->val.i;
return ecl_cons(ecl_make_fixnum(pair >> 16), ecl_make_fixnum(pair & 0xFFFF));
}
cl_object
clbird_make_quad(cl_object quadint)
{
struct f_val *res = clbird_alloc(sizeof(struct f_val));
res->type = T_QUAD;
res->val.i = ecl_to_fix(quadint);
return ecl_make_pointer(res);
}
cl_object
clbird_unmake_quad(cl_object val1_obj)
{
struct f_val *val = ecl_foreign_data_pointer_safe(val1_obj);
if (val->type != T_QUAD) {
FEerror("Can't UNMAKE-QUAD a ~A", 1, eclcs(f_type_name(val->type)));
}
cl_fixnum quad = val->val.i;
return ecl_make_fixnum(quad);
}
cl_object
clbird_val_compare(cl_object val1_obj, cl_object val2_obj)
{
struct f_val *val1 = ecl_foreign_data_pointer_safe(val1_obj);
@ -245,47 +302,9 @@ clbird_val_in_range(cl_object val1_obj, cl_object val2_obj)
return ret ? ECL_T : ECL_NIL;
}
cl_object
clbird_make_quad(cl_object from)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
res->type = T_QUAD;
res->val.i = ecl_to_fix(from);
return ecl_make_pointer(res);
}
cl_object
clbird_make_val(cl_object from)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
if (ECL_FIXNUMP(from)) {
res->type = T_INT;
res->val.i = ecl_to_fix(from);
}
else if (ECL_STRINGP(from)) {
cl_object base = si_coerce_to_base_string(from);
res->type = T_STRING;
res->val.s = base->base_string.self;
}
else if (from == ECL_NIL || from == ECL_T) {
res->type = T_BOOL;
res->val.i = from == ECL_T ? 1 : 0;
}
else if (ECL_CONSP(from) && ECL_FIXNUMP(ECL_CONS_CAR(from)) && ECL_FIXNUMP(ECL_CONS_CDR(from))) {
res->type = T_PAIR;
res->val.i = ecl_to_fix(ECL_CONS_CAR(from)) << 16 | ecl_to_fix(ECL_CONS_CDR(from));
}
else if (ECL_LISTP(from) && ecl_length(from) == 4) {
res->type = T_QUAD;
res->val.i = ecl_to_fix(ecl_elt(from, 0)) << 24 | ecl_to_fix(ecl_elt(from, 1)) << 16 | ecl_to_fix(ecl_elt(from, 2)) << 8 | ecl_to_fix(ecl_elt(from, 3));
}
else {
FEerror("Don't know how to convert to BIRD value: ~A", 1, from);
}
return ecl_make_pointer(res);
}
cl_object
ea_to_object(eattr *e)
{
struct f_val *res = ecl_alloc(sizeof(struct f_val));
struct f_val *res = clbird_alloc(sizeof(struct f_val));
switch (e->type & EAF_TYPE_MASK) {
case EAF_TYPE_INT:
return ecl_make_fixnum(e->u.data);
@ -341,11 +360,26 @@ clbird_get_eattrs(cl_object rte_obj)
}
return ret;
}
cl_object
clbird_get_eattr(cl_object rte_obj, cl_object id_obj)
{
struct rte *rte = ecl_foreign_data_pointer_safe(rte_obj);
cl_fixnum id = ecl_to_fix(id_obj);
for (ea_list *eal = rte->attrs->eattrs; eal; eal=eal->next) {
for (int i = 0; i < eal->count; i++) {
eattr *e = &eal->attrs[i];
if (id == e->id) {
return ea_to_object(e);
}
}
}
return ECL_NIL;
}
void
init_ecl_functions()
{
cl_object package = ecl_find_package("BIRD-IMPL");
cl_object package = ecl_find_package("BIRD-IMPL");
ecl_def_c_function(_ecl_intern("VERSION", package), clbird_version, 0);
ecl_def_c_function(_ecl_intern("HOSTNAME", package), clbird_hostname, 0);
ecl_def_c_function(_ecl_intern("ROUTER-ID", package), clbird_router_id, 0);
@ -357,11 +391,14 @@ init_ecl_functions()
ecl_def_c_function(_ecl_intern("TABLE-ROUTES", package), clbird_get_table_routes_all, 1);
ecl_def_c_function(_ecl_intern("FOR-TABLE-ROUTES", package), clbird_for_table_routes_all, 2);
ecl_def_c_function(_ecl_intern("TABLE-ROUTES-NET", package), clbird_get_table_routes_net, 2);
ecl_def_c_function(_ecl_intern("DOTQUAD", package), clbird_dotquad, 4);
ecl_def_c_function(_ecl_intern("CIDR4", package), clbird_cidr4, 5);
ecl_def_c_function(_ecl_intern("MAKE-VAL", package), clbird_make_val, 1);
ecl_def_c_function(_ecl_intern("UNCIDR4", package), clbird_uncidr4, 1);
ecl_def_c_function(_ecl_intern("MAKE-QUAD", package), clbird_make_quad, 1);
ecl_def_c_function(_ecl_intern("UNMAKE-QUAD", package), clbird_unmake_quad, 1);
ecl_def_c_function(_ecl_intern("MAKE-PAIR", package), clbird_make_pair, 2);
ecl_def_c_function(_ecl_intern("UNMAKE-PAIR", package), clbird_unmake_pair, 1);
ecl_def_c_function(_ecl_intern("ROUTE-EATTRS", package), clbird_get_eattrs, 1);
ecl_def_c_function(_ecl_intern("ROUTE-EATTR", package), clbird_get_eattr, 2);
ecl_def_c_function(_ecl_intern("VAL-TYPE-NAME", package), clbird_val_type_name, 1);
ecl_def_c_function(_ecl_intern("VAL-TYPE-ID", package), clbird_val_type_id, 1);
ecl_def_c_function(_ecl_intern("VAL-COMPARE", package), clbird_val_compare, 2);
@ -401,6 +438,27 @@ ecl_get_string_for(cl_object obj) {
return ret;
}
void
clbird_load_and_byte_compile(char *file)
{
static cl_object bc_compile_file = NULL;
if (bc_compile_file == NULL) {
cl_object compiler_pkg = ecl_find_package("EXT");
assert(compiler_pkg != ECL_NIL);
cl_object sym = _ecl_intern("COMPILE-FILE", compiler_pkg);
bc_compile_file = cl_symbol_function(sym);
assert(bc_compile_file != ECL_NIL);
}
ECL_HANDLER_CASE_BEGIN(ecl_process_env(), ecl_list1(ecl_make_symbol("ERROR", "CL"))) {
log(L_INFO "Byte-compiling and loading Lisp: %s", file);
cl_funcall(4, bc_compile_file, ecls(file), eclk("LOAD"), ECL_T);
log(L_INFO "Lisp successfully loaded");
} ECL_HANDLER_CASE(1, condition) {
char* cond_fmt = ecl_get_string_for(condition);
log(L_WARN "Failed to byte-compile %s: %s", file, cond_fmt);
} ECL_HANDLER_CASE_END;
}
void
clbird_load(char *file)
{

23
filter/filter.c

@ -274,8 +274,17 @@ f_run(const struct filter *filter, struct rte **rte, struct linpool *tmp_pool, i
return F_REJECT;
int rte_cow = ((*rte)->flags & REF_COW);
DBG("Running filter %s...", filter->lisp_name);
printf("Running filter %s...", filter->lisp_name);
clock_t begin = clock();
static unsigned long long num = 0;
static void* alloc_space = NULL;
if (alloc_space == NULL) {
alloc_space = malloc(sizeof(struct f_val) * 1024);
}
extern void* clbird_val_alloc_space;
clbird_val_alloc_space = alloc_space;
static double sum = 0.0;
num += 1;
cl_object package = ecl_find_package("BIRD-FILTER");
assert(package != ECL_NIL);
@ -289,27 +298,31 @@ f_run(const struct filter *filter, struct rte **rte, struct linpool *tmp_pool, i
result = cl_funcall(2, func, ecl_make_pointer(*rte));
} ECL_HANDLER_CASE(1, condition) {
char* err = ecl_get_string_for(condition);
DBG("failed: %s\n", err);
printf("failed: %s\n", err);
log_rl(&rl_runtime_err, L_ERR "Error executing Lisp filter %s: %s", filter->lisp_name, err);
failed = 1;
} ECL_HANDLER_CASE_END;
clbird_val_alloc_space = NULL;
if (failed) {
return F_ERROR;
}
clock_t end = clock();
double time_spent = (double)(end - begin) / CLOCKS_PER_SEC;
sum += time_spent * 1000.0;
num++;
printf("(sum %fms over %llu runs) ", sum, num);
if (ecl_eql(result, eclk("ACCEPT"))) {
DBG("accepted (%fms)\n", time_spent * 1000.0);
printf("accepted (%fms)\n", time_spent * 1000.0);
return F_ACCEPT;
} else if (ecl_eql(result, eclk("REJECT"))) {
DBG("rejected (%fms)\n", time_spent * 1000.0);
printf("rejected (%fms)\n", time_spent * 1000.0);
return F_REJECT;
}
char* ret = ecl_get_string_for(result);
DBG("returned %s (%fms)\n", ret, time_spent * 1000.0);
printf("returned %s (%fms)\n", ret, time_spent * 1000.0);
log_rl(&rl_runtime_err, L_ERR "Unexpected return value for Lisp filter %s: %s", filter->lisp_name, ret);
return F_ERROR;

Loading…
Cancel
Save