[CM] AOT compilation for cload.scm
chohag at jtan.com
chohag at jtan.com
Sat Oct 5 15:08:56 PDT 2024
Hi,
I've made an adaptation of cload.scm that generates code sepatately
so that I can compile extension libraries ahead of time during the
project build phase.
It's incomplete, not least because the new functions I've created
have been split off from c-define with whatever data I needed at
the time without a thought for making a clean design.
But it works and I'm using it so I'm posting it here in case it's
useful.
The original c-define API remains unchanged and there are no real
changes to the implementation except this one:
- (format p "#include <~A>~%" header))
+ (if (string? header)
+ (format p "#include \"~A\"~%" header)
+ (format p "#include <~A>~%" (symbol->string header))))
Everything else is just shuffling things around or breaking functions
into pieces. I've tried to keep the original spacing intact.
I use it like this:
(load "cload.scm")
(unless (defined? '*mylib*) (define *mylib* (with-let (sublet (unlet))
(set! *libraries* (cons (cons "mylib.scm" (curlet)) *libraries*))
(set! *cload-library-name* "*mylib*")
(if (not *cload-generate-only*) ; negative so all the C is last
(c-load "s7lib_mylib")
(c-generate-source "s7lib_mylib" "s7lib_mylib_init"
(list 'assert.h "mylib.h")
((C-function in-C etc.))))
(curlet))))
*mylib*
And in a Makefile:
s7lib_mylib.c: s7run mylib.scm
./s7run '(define *cload-generate-only* #t)' mylib.scm > s7lib_mylib.c
@[ -s s7lib_mylib.c ] || ! rm -f s7lib_mylib.c
s7lib_mylib.so: s7lib_mylib.o
${LINK.c} s7lib_mylib.o -shared -o s7lib_mylib.so
There are five new functions in addition to c-define.
(c-load env libname initname)
This doesn't match (load) which has env last but initname should
be optional.
(c-init-name libname)
Appends "_init" to libname.
(c-create-file libname initname headers c-body prefix)
(c-generate-source libname initname headers c-body prefix)
These should match the c-define calling convention:
(c-define env body prefix headers cflags ldflags outname)
(c-compile cname oname soname cflags ldflags)
Used internally by cload.scm.
At some point I hope to come back to this module and improve the
design but for now I'm getting back to the reason I shaved this
yak. In the meantime here it is, and if anyone can come up with a
better interface then please do.
Cheers,
Matthew
-------------- next part --------------
--- ../s7/cload.scm Sat Oct 5 22:10:09 2024
+++ cload.scm Sat Oct 5 22:11:15 2024
@@ -118,17 +118,14 @@
(defvar c-define-output-file-counter 0) ; ugly, but I can't find a way around this (dlopen/dlsym stupidity)
+(defvar *cload-generate-only* #f)
-;;; to place the new function in the caller's current environment, we need to pass the environment in explicitly:
-(define-macro (c-define . args)
- (cons 'c-define-1 (cons '(curlet) args)))
+(define* (c-create-file library (init-name (c-init-name library)) (headers ()) c-body (prefix ""))
+ (define p (open-output-file (string-append library ".c")))
+ (c-generate-source library init-name headers c-body prefix p)
+ (close-output-port p))
-
-(define* (c-define-1 cur-env function-info (prefix "") (headers ()) (cflags "") (ldflags "") output-name)
- ;; write a C shared library module that links in the functions in function-info
- ;; function info is either a list: (return-type c-name arg-type) or a list thereof
- ;; the new functions are placed in cur-env
-
+(define* (c-generate-source library (init-name (c-init-name library)) (headers ()) c-body (prefix "") (port ()))
(define handlers (list '(integer s7_is_integer s7_integer s7_make_integer s7_int)
'(boolean s7_is_boolean s7_boolean s7_make_boolean bool)
'(real s7_is_real s7_number_to_real_with_caller s7_make_real s7_double)
@@ -205,20 +202,8 @@
((c-pointer?) #\x)
(else #\t)))
- (set! c-define-output-file-counter (+ c-define-output-file-counter 1))
- (let ((file-name (string-append *cload-directory*
- (if (and (> (length *cload-directory*) 0)
- (not (char=? (string-ref *cload-directory* (- (length *cload-directory*) 1)) #\/)))
- "/" "")
- (or output-name (format #f "temp-s7-output-~D" c-define-output-file-counter)))))
- (let ((c-file-name (string-append file-name ".c"))
- (o-file-name (string-append file-name ".o"))
- (so-file-name (string-append file-name ".so"))
- (init-name (if (string? output-name)
- (string-append output-name "_init")
- (string-append "init_" (number->string c-define-output-file-counter))))
- (functions ())
+ (let ((functions ())
(constants ())
(macros ()) ; these are protected by #ifdef ... #endif
(inits ()) ; C code (a string in s7) inserted in the library initialization function
@@ -278,7 +263,7 @@
(define (initialize-c-file)
;; C header stuff
- (set! p (open-output-file c-file-name))
+ (set! p port)
(format p "#include <stdlib.h>~%")
(format p "#include <stdio.h>~%")
(format p "#include <string.h>~%")
@@ -286,7 +271,9 @@
(format p "#include <~A>~%" headers)
(for-each
(lambda (header)
- (format p "#include <~A>~%" header))
+ (if (string? header)
+ (format p "#include \"~A\"~%" header)
+ (format p "#include <~A>~%" (symbol->string header))))
headers))
(format p "#include \"s7.h\"~%~%")
(format p "static s7_pointer fsym, s7_F, s7_unspec, ffunc, c_pointer_string, string_string, character_string, boolean_string, real_string, complex_string, integer_string;~%"))
@@ -507,9 +494,9 @@
(format p "~A~A~A" (cdr sym) (if (< loc len) (values "," " ") (values ";" #\newline)))
(set! loc (+ loc 1)))
type-symbols)))
- (newline p)
+ (format p "~%")
- (display (get-output-string pp) p)
+ (format p (get-output-string pp))
(close-output-port pp)
;; now the init function
@@ -578,7 +565,7 @@
(reverse inits))
(when (pair? type-symbols)
- (newline p)
+ (format p "~%")
(for-each
(lambda (sym)
(format p " ~S = s7_make_symbol(sc, ~S);~%" (cdr sym) (symbol->string (car sym))))
@@ -676,52 +663,8 @@
(format p " s7_set~A_function(sc, s7_name_to_value(sc, ~S), ~A~A);~%" (caddr f) (cadr f) (car f) (caddr f))))
double-int-funcs))
- (format p "}~%")
- (close-output-port p)
+ (format p "}~%"))
- (unless (or (file-exists? "s7.h")
- (not (pair? *load-path*)))
- (set! *cload-cflags* (append *cload-cflags* (format #f " -I~A" (car *load-path*)))))
-
- ;; now we have the module .c file -- make it into a shared object
-
- (cond ((provided? 'osx)
- ;; I assume the caller is also compiled with these flags?
- (system (format #f "~A -c ~A -o ~A ~A ~A"
- *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
- (system (format #f "~A ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"
- *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
-
- ((provided? 'freebsd)
- (system (format #f "cc -fPIC -c ~A -o ~A ~A ~A"
- c-file-name o-file-name *cload-cflags* cflags))
- (system (format #f "cc ~A -shared -o ~A ~A ~A"
- o-file-name so-file-name *cload-ldflags* ldflags)))
-
- ((provided? 'openbsd)
- (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A"
- *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
- (system (format #f "~A ~A -shared -o ~A ~A ~A"
- *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
-
- ((provided? 'sunpro_c) ; just guessing here...
- (system (format #f "cc -c ~A -o ~A ~A ~A"
- c-file-name o-file-name *cload-cflags* cflags))
- (system (format #f "cc ~A -G -o ~A ~A ~A"
- o-file-name so-file-name *cload-ldflags* ldflags)))
-
- ((or (provided? 'mingw) (provided? 'msys2)) ; from chai xiaoxiang
- ;; you'll need dlfcn which can be installed with pacman, and remember to build s7 with -DWITH_C_LOADER=1
- ;; in msys2: gcc s7.c -o s7 -DWITH_MAIN -DWITH_C_LOADER=1 -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
- (system (format #f "gcc ~A s7.lib -shared -o ~A -I. ~A ~A"
- c-file-name so-file-name cflags ldflags)))
-
- (else ; linux netbsd
- (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A"
- *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
- (system (format #f "~A ~A -shared -o ~A ~A ~A"
- *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))))
-
(define handle-declaration
(let ()
(define (add-one-constant type name)
@@ -765,6 +708,95 @@
(error 'wrong-type-arg "~S (func arg to handle-declaration in cload.scm) should be a pair" func)))))
+ (initialize-c-file)
+
+ (if (and (pair? (cdr c-body))
+ (symbol? (cadr c-body)))
+ (handle-declaration c-body)
+ (for-each handle-declaration c-body))
+
+ (end-c-file)))
+
+
+(define (c-compile c-file-name o-file-name so-file-name cflags ldflags)
+ (unless (or (file-exists? "s7.h")
+ (not (pair? *load-path*)))
+ (set! *cload-cflags* (append *cload-cflags* (format #f " -I~A" (car *load-path*)))))
+
+ ;; now we have the module .c file -- make it into a shared object
+
+ (cond ((provided? 'osx)
+ ;; I assume the caller is also compiled with these flags?
+ (system (format #f "~A -c ~A -o ~A ~A ~A"
+ *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "~A ~A -o ~A -dynamic -bundle -undefined suppress -flat_namespace ~A ~A"
+ *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'freebsd)
+ (system (format #f "cc -fPIC -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "cc ~A -shared -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'openbsd)
+ (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A"
+ *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "~A ~A -shared -o ~A ~A ~A"
+ *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((provided? 'sunpro_c) ; just guessing here...
+ (system (format #f "cc -c ~A -o ~A ~A ~A"
+ c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "cc ~A -G -o ~A ~A ~A"
+ o-file-name so-file-name *cload-ldflags* ldflags)))
+
+ ((or (provided? 'mingw) (provided? 'msys2)) ; from chai xiaoxiang
+ ;; you'll need dlfcn which can be installed with pacman, and remember to build s7 with -DWITH_C_LOADER=1
+ ;; in msys2: gcc s7.c -o s7 -DWITH_MAIN -DWITH_C_LOADER=1 -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
+ (system (format #f "gcc ~A s7.lib -shared -o ~A -I. ~A ~A"
+ c-file-name so-file-name cflags ldflags)))
+
+ (else ; linux netbsd
+ (system (format #f "~A -fPIC -c ~A -o ~A ~A ~A"
+ *cload-c-compiler* c-file-name o-file-name *cload-cflags* cflags))
+ (system (format #f "~A ~A -shared -o ~A ~A ~A"
+ *cload-c-compiler* o-file-name so-file-name *cload-ldflags* ldflags)))))
+
+
+(define-macro (c-load . args)
+ `(,c-load-1 ,(curlet) , at args))
+
+(define* (c-load-1 env library (init (c-init-name library)))
+ (varlet env 'init_func (string->symbol init))
+ (load (string-append library ".so") env)) ;; Did you call yours dylib for no reason? So?
+
+
+;;; to place the new function in the caller's current environment, we need to pass the environment in explicitly:
+(define-macro (c-define . args)
+ (cons 'c-define-1 (cons '(curlet) args)))
+
+
+(define (c-init-name output-name)
+ (if (string? output-name)
+ (string-append output-name "_init")
+ (string-append "init_" (number->string c-define-output-file-counter))))
+
+
+(define* (c-define-1 cur-env function-info (prefix "") (headers ()) (cflags "") (ldflags "") output-name)
+ ;; write a C shared library module that links in the functions in function-info
+ ;; function info is either a list: (return-type c-name arg-type) or a list thereof
+ ;; the new functions are placed in cur-env
+
+ (let ((file-name (string-append *cload-directory*
+ (if (and (> (length *cload-directory*) 0)
+ (not (char=? (string-ref *cload-directory* (- (length *cload-directory*) 1)) #\/)))
+ "/" "")
+ (or output-name (format #f "temp-s7-output-~D" c-define-output-file-counter)))))
+ (let ((c-file-name (string-append file-name ".c"))
+ (o-file-name (string-append file-name ".o"))
+ (so-file-name (string-append file-name ".so"))
+ (init-name (c-init-name output-name)))
+
;; c-define-1 (called in c-define macro above)
(unless (and output-name
(file-exists? c-file-name)
@@ -773,23 +805,15 @@
(>= (file-mtime so-file-name) (file-mtime c-file-name))
(not (and (file-exists? (port-filename))
(< (file-mtime so-file-name) (file-mtime (port-filename))))))
- (format *stderr* "writing ~A~%" c-file-name)
;; write a new C file and compile it
- (initialize-c-file)
-
- (if (and (pair? (cdr function-info))
- (symbol? (cadr function-info)))
- (handle-declaration function-info)
- (for-each handle-declaration function-info))
-
- (end-c-file)
+ (format *stderr* "writing ~A~%" c-file-name)
+ (c-create-file output-name init-name headers function-info prefix) ;; (map string->symbol headers)
+ (c-compile c-file-name o-file-name so-file-name cflags ldflags)
(delete-file o-file-name))
;; load the object file, clean up
- (varlet cur-env 'init_func (string->symbol init-name))
(format *stderr* "loading ~A~%" so-file-name)
- (load so-file-name cur-env))))
-
+ (c-load-1 cur-env output-name init-name))))
#|
(let ((cd (symbol "complex double"))
More information about the Cmdist
mailing list