The compiler can now generate some Lisp constants as static C expressions (based on patches by JC Beaudoin)

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

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
 

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)

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))

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 "~%};")))))
 
 ;;; ----------------------------------------------------------------------

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))))))))

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)