add define-probes

CMakeLists.txt

@@ -1,4 +1,4 @@
-cmake_minimum_required(VERSION 3.10)
+cmake_minimum_required(VERSION 3.30)
 project(ftracetool C)
 
 set(CMAKE_C_STANDARD 23)
@@ -24,8 +24,13 @@ message(STATUS "Libelf libraries: ${LIBELF_LIBRARIES}")
 message(STATUS "Chibi-scheme include dirs: ${CHIBI_SCHEME_INCLUDE_DIRS}")
 message(STATUS "Chibi-scheme libraries: ${CHIBI_SCHEME_LIBRARIES}")
 
+add_custom_target(ftracetool_scm.h
+    COMMAND xxd -i < ${CMAKE_SOURCE_DIR}/src/ftracetool.scm > ${CMAKE_CURRENT_BINARY_DIR}/ftracetool_scm.h)
+
 add_executable(ftracetool ${SOURCES})
 
+add_dependencies(ftracetool ftracetool_scm.h)
+target_include_directories(ftracetool PRIVATE ${CMAKE_CURRENT_BINARY_DIR})
 target_include_directories(ftracetool PRIVATE ${LIBELF_INCLUDE_DIRS} ${CHIBI_SCHEME_INCLUDE_DIRS})
 target_link_libraries(ftracetool PRIVATE ${LIBELF_LIBRARIES} ${CHIBI_SCHEME_LIBRARIES})
 

src/ftracetool.c

@@ -17,6 +17,10 @@
 
 #define CLEANUP(f) __attribute__((cleanup(f)))
 
+static const char gs_ftracetool_scm[] = {
+#include "ftracetool_scm.h"
+};
+
 struct ftt_mapping
 {
     char *key;
@@ -300,11 +304,28 @@ static int register_ftracetool_api(sexp ctx)
         sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_STRING);
         sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_STRING);
     }
-    sexp_gc_release3(ctx);
+    sexp_gc_release1(ctx);
 
     return 0;
 }
 
+static int eval_ftracetool_scm(sexp ctx)
+{
+    sexp_gc_var2(ret, fname);
+    sexp_gc_preserve2(ctx, ret, fname);
+    fname = sexp_c_string(ctx, "ftracetool.scm", -1);
+    ret = sexp_load(ctx, fname, sexp_context_env(ctx));
+    if (sexp_exceptionp(ret))
+    {
+        fprintf(stderr, "Exception occured while eval ftracetool_scm:\n");
+        sexp_print_exception(ctx, ret, sexp_current_output_port(ctx));
+        return EXIT_FAILURE;
+    }
+
+    sexp_gc_release2(ctx);
+    return 0;
+}
+
 static int do_execute_script(const char *const filename)
 {
     int ret = EXIT_SUCCESS;
@@ -324,6 +345,12 @@ static int do_execute_script(const char *const filename)
         return EXIT_FAILURE;
     }
 
+    if (eval_ftracetool_scm(ctx))
+    {
+        fprintf(stderr, "Unable to register ftracetool.scm API\n");
+        return EXIT_FAILURE;
+    }
+
     filename_obj = sexp_c_string(ctx, filename, -1);
     scheme_ret = sexp_load(ctx, filename_obj, NULL);
     if (sexp_exceptionp(scheme_ret))

src/ftracetool.scm

@@ -0,0 +1,51 @@
+(import (scheme base))
+(import (srfi 16))
+
+(define (mapping-str key)
+  (let ((pair (assoc key *ftt-mappings*)))
+    (if pair
+        (cdr pair)
+        (raise (string-append "No mapping: " key)))))
+
+(define (mapping-int key)
+  (let ((value (mapping-str key)))
+    (when value
+      (string->number value))))
+
+(define-record-type probe
+  (make-probe
+   install-handler
+   remove-handler
+   process-handler)
+  probe?
+  (install-handler probe-install-handler)
+  (remove-handler probe-remove-handler)
+  (process-handler probe-process-handler))
+
+(define define-probes
+  (case-lambda
+   (() (display "Do waiting\n"))
+   ((probe . rest)
+    (display "Got probe: ")
+    (display probe)
+    (newline)
+    (let ((token ((probe-install-handler probe))))
+      (guard (x
+              (else
+               (display "Error:")
+               (display x)
+               (newline)))
+             (apply define-probes rest)
+             ((probe-process-handler probe)))
+      ((probe-remove-handler probe) token))
+    ))
+  )
+
+(define (ftrace-uprobe probe-name binary-path symbol args handler)
+  (list 'uprobe probe-name binary-path symbol args handler))
+
+(define (tracing-probe ctx install remove process)
+  (make-probe (lambda () (install ctx))
+              (lambda (_) (remove ctx))
+              (lambda () (process ctx))))
+