From d16986387725da4f11e181cd59704a7c249d9306 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 7 Jun 2009 18:18:27 +0200 Subject: [PATCH] The compiler can now generate some Lisp constants as static C expressions (based on patches by JC Beaudoin) --- src/CHANGELOG | 3 +++ src/cmp/cmpdefs.lsp | 7 ++++++- src/cmp/cmpenv.lsp | 1 + src/cmp/cmpmac.lsp | 2 +- src/cmp/cmptop.lsp | 39 ++++++++++++++++++++++++------------ src/cmp/cmpwt.lsp | 49 ++++++++++++++++++++++++++++++++++++++++++--- src/h/ecl-cmp.h | 19 ++++++++++++++++++ 7 files changed, 102 insertions(+), 18 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index d813b4eda..57671325a 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -74,6 +74,9 @@ ECL 9.5: - Compiled functions now carry information about their source file (based on patches by JC Beaudoin) + - The compiler can now generate some Lisp constants as static C expressions + (based on patches by JC Beaudoin) + * Bugs fixed: - Remove an obsolete #if statement for Solaris that broke current builds diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 2ded8f2de..da176c0ca 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -183,7 +183,7 @@ ;;; We only register direct calls, not calls via object. (child-funs nil) ;;; List of local functions defined here. (debug 0) ;;; Debug quality - (file *compile-file-pathname*) + (file *compile-file-truename*) ;;; Source file or NIL (file-position *compile-file-position*) ;;; Top-level form number in source file @@ -509,6 +509,11 @@ lines are inserted, but the order is preserved") ;;; where each vv-index should be given an object before ;;; defining the current function during loading process. +(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may + ; generate lisp constant values as C structs +(defvar *static-constants* nil) ; constants that can be built as C values + ; holds { ( object c-variable constant ) }* + (defvar *compiler-constants* nil) ; a vector with all constants ; only used in COMPILE diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 874c36222..d7ea3483f 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -30,6 +30,7 @@ (*last-label* 0) (*load-objects* (make-hash-table :size 128 :test #'equal)) (*make-forms* nil) + (*static-constants* nil) (*permanent-objects* nil) (*temporary-objects* nil) (*local-funs* nil) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index 67f915aa6..a2ea818ad 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -89,7 +89,7 @@ :type (info-type subform) :sp-change (info-sp-change subform) :volatile (info-volatile subform) - :file *compile-file-pathname* + :file *compile-file-truename* :file-position *compile-file-position*))) (c1form-add-info form args) form)) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index a30abb99a..23e4e9122 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -148,8 +148,9 @@ (wt-nl "flag->cblock.data_text_size = compiler_data_text_size;") (wt-nl "flag->cblock.cfuns_size = compiler_cfuns_size;") (wt-nl "flag->cblock.cfuns = compiler_cfuns;") - (wt-nl "flag->cblock.source = make_constant_base_string(\"" - (namestring *compile-file-truename*) "\");") + (when *compile-file-truename* + (wt-nl "flag->cblock.source = make_constant_base_string(\"" + (namestring *compile-file-truename*) "\");")) (wt-nl "return;}") (wt-nl "#ifdef ECL_DYNAMIC_VV") (wt-nl "VV = Cblock->cblock.data;") @@ -169,10 +170,10 @@ ;; useless in initialization. (dolist (form (nconc (nreverse *make-forms*) *top-level-forms*)) - (let ((*compile-to-linking-call* nil) - (*compile-file-pathname* (c1form-file form)) - (*compile-file-position* (c1form-file-position form)) - (*env* 0) (*level* 0) (*temp* 0)) + (let* ((*compile-to-linking-call* nil) + (*compile-file-truename* (and form (c1form-file form))) + (*compile-file-position* (and form (c1form-file-position form))) + (*env* 0) (*level* 0) (*temp* 0)) (t2expr form)) (let ((*compiler-output1* c-output-file)) (emit-local-funs))) @@ -224,6 +225,15 @@ (wt-nl-h "}") (wt-nl-h "#endif") + (when (and (listp *static-constants*) + (setf *static-constants* (nreverse *static-constants*))) + (wt-nl-h "/*") + (wt-nl-h " * Statically defined constants") + (wt-nl-h " */") + (loop for (value name builder) in (reverse *static-constants*) + do (terpri *compiler-output2*) + do (funcall builder name value *compiler-output2*))) + (output-cfuns *compiler-output2*) (setq *compiler-phase* 't3) @@ -697,6 +707,9 @@ (defun output-cfuns (stream) (let ((n-cfuns (length *global-cfuns-array*))) + (wt-nl-h "/*") + (wt-nl-h " * Exported Lisp functions") + (wt-nl-h " */") (wt-nl-h "#define compiler_cfuns_size " n-cfuns) (if (zerop n-cfuns) (wt-nl-h "#define compiler_cfuns NULL") @@ -704,13 +717,13 @@ (format stream "~%static const struct ecl_cfun compiler_cfuns[] = {~ ~%~t/*t,m,narg,padding,name,block,entry*/"); (loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*) - do (let* ((cfun (fun-cfun fun)) - (minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (narg (if (= minarg maxarg) maxarg nil))) - (format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),MAKE_FIXNUM(~D),(cl_objectfn)~A,Ct,MAKE_FIXNUM(~D)}," - (or narg -1) (second loc) (second fname-loc) - cfun (fun-file-position fun)))) + do (let* ((cfun (fun-cfun fun)) + (minarg (fun-minarg fun)) + (maxarg (fun-maxarg fun)) + (narg (if (= minarg maxarg) maxarg nil))) + (format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),MAKE_FIXNUM(~D),(cl_objectfn)~A,Ct,MAKE_FIXNUM(~D)}," + (or narg -1) (second loc) (second fname-loc) + cfun (fun-file-position fun)))) (format stream "~%};"))))) ;;; ---------------------------------------------------------------------- diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 20addcdba..50da182a8 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -86,11 +86,11 @@ ;;; to split long lines using the fact that multiple strings are joined ;;; together by the compiler. ;;; -(defun wt-filtered-data (string stream) +(defun wt-filtered-data (string stream &optional one-liner) (let ((N (length string)) (wt-data-column 80)) (incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space - (format stream "~%\"") + (format stream (if one-liner "\"" "~%\"")) (dotimes (i N) (decf wt-data-column) (when (< wt-data-column 0) @@ -226,7 +226,8 @@ (find object array :test test :key #'first))) (next-ndx (length array)) found) - (cond ((and x duplicate) + (cond ((add-static-constant object)) + ((and x duplicate) (setq x (list vv next-ndx)) (vector-push-extend (list object x next-ndx) array) x) @@ -264,3 +265,45 @@ (add-object (pop keywords) :duplicate t :permanent t) (dolist (k keywords) (add-object k :duplicate t :permanent t)))))) + +;;; ====================================================================== +;;; +;;; STATIC CONSTANTS +;;; + +(defun static-base-string-builder (name value stream) + (format stream "ecl_def_ct_base_string(~A," name) + (wt-filtered-data value stream t) + (format stream ",~D,static,const);" (length value))) + +(defun static-single-float-builder (name value stream) + (let* ((*read-default-float-format* 'single-float) + (*print-readably* t)) + (format stream "ecl_def_ct_single_float(~A,~S,static,const);" name value stream))) + +(defun static-double-float-builder (name value stream) + (let* ((*read-default-float-format* 'double-float) + (*print-readably* t)) + (format stream "ecl_def_ct_single_float(~A,~S,static,const);" name value stream))) + +(defun static-constant-builder (format value) + (lambda (name stream) + (format stream format name value))) + +(defun static-constant-expression (object) + (typecase object + (base-string #'static-base-string-builder) + ;;(single-float #'static-single-float-builder) + ;;(double-float #'static-double-float-builder) + (t nil))) + +(defun add-static-constant (object) + (unless (or *compiler-constants* (not (listp *static-constants*))) + (let ((record (find object *static-constants* :key #'first :test #'equal))) + (if record + (second record) + (let ((builder (static-constant-expression object))) + (when builder + (let* ((c-name (format nil "_ecl_static_~D" (length *static-constants*)))) + (push (list object c-name builder) *static-constants*) + `(VV ,c-name)))))))) diff --git a/src/h/ecl-cmp.h b/src/h/ecl-cmp.h index d79612cbe..37b9be9f4 100644 --- a/src/h/ecl-cmp.h +++ b/src/h/ecl-cmp.h @@ -25,3 +25,22 @@ #define TRAMPOLINK(narg, vv, lk, cblock) \ cl_va_list args; cl_va_start(args, narg, narg, 0); \ return(_ecl_link_call(vv, (cl_objectfn *)lk, cblock, narg, args)) + +#define ecl_def_ct_base_string(name,chars,len,static,const) \ + static const struct ecl_base_string name ## data = { \ + (int8_t)t_base_string, 0, FALSE, FALSE, \ + Cnil, (cl_index)(len), (cl_index)(len), \ + (ecl_base_char*)(chars) }; \ + static const cl_object name = (cl_object)(& name ## data) + +#define ecl_def_ct_single_float(name,f,static,const) \ + static const struct ecl_doublefloat name ## data = { \ + (int8_t)t_singlefloat, 0, 0, 0, \ + (float)(f) }; \ + static const cl_object name = (cl_object)(& name ## data) + +#define ecl_def_ct_double_float(name,f,static,const) \ + static const struct ecl_singlefloat name ## data = { \ + (int8_t)t_doublefloat, 0, 0, 0, \ + (double)(f) }; \ + static const cl_object name = (cl_object)(& name ## data)