diff --git a/src/cmp/cmpc-machine.lsp b/src/cmp/cmpc-machine.lsp index 83925c46f..95e9d024b 100644 --- a/src/cmp/cmpc-machine.lsp +++ b/src/cmp/cmpc-machine.lsp @@ -16,92 +16,84 @@ (in-package "COMPILER") +;; These types can be used by ECL to unbox data They are sorted from +;; the most specific, to the least specific one. All functions must +;; be declared in external.h (not internal.h) header file. (defconstant +representation-types+ - '(;; These types can be used by ECL to unbox data - ;; They are sorted from the most specific, to the least specific one. - ;; All functions must be declared in externa.h (not internal.h) header file. - (:byte . - #1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum")) - (:unsigned-byte . - #2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum")) - (:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum") - (:int integer "int" "ecl_make_int" "ecl_to_int" "ecl_to_int") - (:unsigned-int integer "unsigned int" "ecl_make_uint" "ecl_to_uint" "ecl_to_uint") - (:long integer "long" "ecl_make_long" "ecl_to_long" "ecl_to_long") - (:unsigned-long integer "unsigned long" "ecl_make_ulong" "ecl_to_ulong" "ecl_to_ulong") - (:cl-index integer "cl_index" "ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum") - (:long-long integer "ecl_long_long_t" "ecl_make_long_long" "ecl_to_long_long" "ecl_to_long_long") - (:unsigned-long-long integer "ecl_ulong_long_t" "ecl_make_ulong_long" "ecl_to_ulong_long" "ecl_to_ulong_long") - (:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float") - (:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float") - (:long-double long-float "long double" "ecl_make_long_float" "ecl_to_long_double" "ecl_long_float") - (:csfloat si::complex-single-float "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat") - (:cdfloat si::complex-double-float "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat") - (:clfloat si::complex-long-float "_Complex long double" "ecl_make_clfloat" "ecl_to_clfloat" "ecl_clfloat") - (:unsigned-char base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") - (:char base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") - (:wchar character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE") - (:float-sse-pack ext::float-sse-pack "__m128" "ecl_make_float_sse_pack" - "ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe") - (:double-sse-pack ext::double-sse-pack "__m128d" "ecl_make_double_sse_pack" - "ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe") - (:int-sse-pack ext::sse-pack #|<-intentional|# "__m128i" "ecl_make_int_sse_pack" - "ecl_unbox_int_sse_pack" "ecl_unbox_int_sse_pack_unsafe") - (:object t "cl_object") - (:bool t "bool" "ecl_make_bool" "ecl_to_bool" "ecl_to_bool") + ;; ffi-type lisp type c type convert C->Lisp convert Lisp->C unbox Lisp->C (unsafe) + '((:byte . #1=((signed-byte 8) "int8_t" "ecl_make_int8_t" "ecl_to_int8_t" "ecl_fixnum")) + (:unsigned-byte . #2=((unsigned-byte 8) "uint8_t" "ecl_make_uint8_t" "ecl_to_uint8_t" "ecl_fixnum")) + (:fixnum integer "cl_fixnum" "ecl_make_fixnum" "ecl_to_fixnum" "ecl_fixnum") + (:int integer "int" "ecl_make_int" "ecl_to_int" "ecl_to_int") + (:unsigned-int integer "unsigned int" "ecl_make_uint" "ecl_to_uint" "ecl_to_uint") + (:long integer "long" "ecl_make_long" "ecl_to_long" "ecl_to_long") + (:unsigned-long integer "unsigned long" "ecl_make_ulong" "ecl_to_ulong" "ecl_to_ulong") + (:cl-index integer "cl_index" "ecl_make_unsigned_integer" "ecl_to_cl_index" "ecl_fixnum") + (:long-long integer "ecl_long_long_t" "ecl_make_long_long" "ecl_to_long_long" "ecl_to_long_long") + (:unsigned-long-long integer "ecl_ulong_long_t" "ecl_make_ulong_long" "ecl_to_ulong_long" "ecl_to_ulong_long") + (:float single-float "float" "ecl_make_single_float" "ecl_to_float" "ecl_single_float") + (:double double-float "double" "ecl_make_double_float" "ecl_to_double" "ecl_double_float") + (:long-double long-float "long double" "ecl_make_long_float" "ecl_to_long_double" "ecl_long_float") + (:csfloat si::complex-single-float "_Complex float" "ecl_make_csfloat" "ecl_to_csfloat" "ecl_csfloat") + (:cdfloat si::complex-double-float "_Complex double" "ecl_make_cdfloat" "ecl_to_cdfloat" "ecl_cdfloat") + (:clfloat si::complex-long-float "_Complex long double" "ecl_make_clfloat" "ecl_to_clfloat" "ecl_clfloat") + (:unsigned-char base-char "unsigned char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") + (:char base-char "char" "CODE_CHAR" "ecl_base_char_code" "CHAR_CODE") + (:wchar character "ecl_character" "CODE_CHAR" "ecl_char_code" "CHAR_CODE") + (:float-sse-pack ext::float-sse-pack "__m128" "ecl_make_float_sse_pack" "ecl_unbox_float_sse_pack" "ecl_unbox_float_sse_pack_unsafe") + (:double-sse-pack ext::double-sse-pack "__m128d" "ecl_make_double_sse_pack" "ecl_unbox_double_sse_pack" "ecl_unbox_double_sse_pack_unsafe") + ;; intentional v + (:int-sse-pack ext::sse-pack "__m128i" "ecl_make_int_sse_pack" "ecl_unbox_int_sse_pack" "ecl_unbox_int_sse_pack_unsafe") + (:object t "cl_object" nil nil nil) + (:bool t "bool" "ecl_make_bool" "ecl_to_bool" "ecl_to_bool") ;; These types are never selected to unbox data. ;; They are here, because we need to know how to print them. - (:void nil "void") - (:pointer-void si::foreign-data "void*" "ecl_make_pointer" "ecl_to_pointer" "ecl_to_pointer") - (:cstring string "char*" "ecl_cstring_to_base_string_or_nil") - (:char* string "char*") - (:int8-t . #1#) - (:uint8-t . #2#) - (:int16-t integer "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t" "ecl_to_int16_t") - (:uint16-t integer "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_to_unt16_t") - (:int32-t integer "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t" "ecl_to_int32_t") - (:uint32-t integer "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t" "ecl_to_uint32_t") - (:int64-t integer "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t") - (:uint64-t integer "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t") - (:short integer "short" "ecl_make_short" "ecl_to_short" "ecl_fixnum") - (:unsigned-short integer "unsigned short" "ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum") - )) + (:void nil "void" nil nil nil) + (:pointer-void si::foreign-data "void*" "ecl_make_pointer" "ecl_to_pointer" "ecl_to_pointer") + (:cstring string "char*" "ecl_cstring_to_base_string_or_nil" nil nil) + (:char* string "char*" nil nil nil) + (:int8-t . #1#) + (:uint8-t . #2#) + (:int16-t integer "ecl_int16_t" "ecl_make_int16_t" "ecl_to_int16_t" "ecl_to_int16_t") + (:uint16-t integer "ecl_uint16_t" "ecl_make_uint16_t" "ecl_to_uint16_t" "ecl_to_unt16_t") + (:int32-t integer "ecl_int32_t" "ecl_make_int32_t" "ecl_to_int32_t" "ecl_to_int32_t") + (:uint32-t integer "ecl_uint32_t" "ecl_make_uint32_t" "ecl_to_uint32_t" "ecl_to_uint32_t") + (:int64-t integer "ecl_int64_t" "ecl_make_int64_t" "ecl_to_int64_t" "ecl_to_int64_t") + (:uint64-t integer "ecl_uint64_t" "ecl_make_uint64_t" "ecl_to_uint64_t" "ecl_to_uint64_t") + (:short integer "short" "ecl_make_short" "ecl_to_short" "ecl_fixnum") + (:unsigned-short integer "unsigned short" "ecl_make_ushort" "ecl_to_ushort" "ecl_fixnum"))) + +;; FIXME number of bits is used for bit fiddling optimizations. That +;; information should be defined separately. -- jd 2019-11-27 (defconstant +this-machine-c-types+ - '((:byte . -8) - (:unsigned-byte . 8) - (:unsigned-short . #.(- (logcount ffi:c-ushort-max))) - (:short . #.(- (logcount ffi:c-ushort-max))) - (:unsigned-int . #.(logcount ffi:c-uint-max)) - (:int . #.(- (logcount ffi:c-uint-max))) - (:unsigned-long . #.(logcount ffi:c-ulong-max)) - (:long . #.(- (logcount ffi:c-ulong-max))) - #+long-long - (:unsigned-long-long . #.(logcount ffi:c-ulong-long-max)) - #+long-long - (:long-long . #.(- (logcount ffi:c-ulong-long-max))) - (:cl-index . #.(logcount most-positive-fixnum)) - (:fixnum . #.(- -1 (logcount most-positive-fixnum))) - (:uint8-t . 8) - (:int8-t . -8) - #+:uint16-t - (:uint16-t . 16) - #+:uint16-t - (:int16-t . -16) - #+:uint32-t - (:uint32-t . 32) - #+:uint32-t - (:int32-t . -32) - #+:uint64-t - (:uint64-t . 64) - #+:uint64-t - (:int64-t . -64) - #+:sse2 (:float-sse-pack . nil) - #+:sse2 (:double-sse-pack . nil) - #+:sse2 (:int-sse-pack . nil) - #+complex-float (:csfloat . nil) - #+complex-float (:cdfloat . nil) - #+complex-float (:clfloat . nil))) + ;; type integer bits (negative means "signed") + '((:byte . -8) + (:unsigned-byte . 8) + (:unsigned-short . #.(- (logcount ffi:c-ushort-max))) + (:short . #.(- (logcount ffi:c-ushort-max))) + (:unsigned-int . #.(logcount ffi:c-uint-max)) + (:int . #.(- (logcount ffi:c-uint-max))) + (:unsigned-long . #.(logcount ffi:c-ulong-max)) + (:long . #.(- (logcount ffi:c-ulong-max))) + #+long-long (:unsigned-long-long . #.(logcount ffi:c-ulong-long-max)) + #+long-long (:long-long . #.(- (logcount ffi:c-ulong-long-max))) + (:cl-index . #.(logcount most-positive-fixnum)) + (:fixnum . #.(- -1 (logcount most-positive-fixnum))) + (:uint8-t . 8) + (:int8-t . -8) + #+:uint16-t (:uint16-t . 16) + #+:uint16-t (:int16-t . -16) + #+:uint32-t (:uint32-t . 32) + #+:uint32-t (:int32-t . -32) + #+:uint64-t (:uint64-t . 64) + #+:uint64-t (:int64-t . -64) + #+:sse2 (:float-sse-pack . nil) + #+:sse2 (:double-sse-pack . nil) + #+:sse2 (:int-sse-pack . nil) + #+complex-float (:csfloat . nil) + #+complex-float (:cdfloat . nil) + #+complex-float (:clfloat . nil))) (defconstant +all-machines-c-types+ '((:object) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 13910d7ba..1404eff0b 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -15,9 +15,56 @@ (in-package "COMPILER") +(defconstant +foreign-elt-type-codes+ + '( (:char . "ECL_FFI_CHAR") + (:unsigned-char . "ECL_FFI_UNSIGNED_CHAR") + (:byte . "ECL_FFI_BYTE") + (:unsigned-byte . "ECL_FFI_UNSIGNED_BYTE") + (:short . "ECL_FFI_SHORT") + (:unsigned-short . "ECL_FFI_UNSIGNED_SHORT") + (:int . "ECL_FFI_INT") + (:unsigned-int . "ECL_FFI_UNSIGNED_INT") + (:long . "ECL_FFI_LONG") + (:unsigned-long . "ECL_FFI_UNSIGNED_LONG") + #+:uint16-t (:int16-t . "ECL_FFI_INT16_T") + #+:uint16-t (:uint16-t . "ECL_FFI_UINT16_T") + #+:uint32-t (:int32-t . "ECL_FFI_INT32_T") + #+:uint32-t (:uint32-t . "ECL_FFI_UINT32_T") + #+:uint64-t (:int64-t . "ECL_FFI_INT64_T") + #+:uint64-t (:uint64-t . "ECL_FFI_UINT64_T") + #+:long-long (:long-long . "ECL_FFI_LONG_LONG") + #+:long-long (:unsigned-long-long . "ECL_FFI_UNSIGNED_LONG_LONG") + (:pointer-void . "ECL_FFI_POINTER_VOID") + (:cstring . "ECL_FFI_CSTRING") + (:object . "ECL_FFI_OBJECT") + (:float . "ECL_FFI_FLOAT") + (:double . "ECL_FFI_DOUBLE") + (:long-double . "ECL_FFI_LONG_DOUBLE") + #+complex-float (:csfloat . "ECL_FFI_CSFLOAT") + #+complex-float (:cdfloat . "ECL_FFI_CDFLOAT") + #+complex-float (:clfloat . "ECL_FFI_CLFLOAT") + (:void . "ECL_FFI_VOID"))) + +(defun foreign-elt-type-code (type) + (let ((x (assoc type +foreign-elt-type-codes+))) + (unless x + (cmperr "DEFCALLBACK: ~a is not a valid elementary FFI type." type)) + (cdr x))) + +;;; We could have made FFI:DEFCALLBACK to accept any ffi type defined +;;; for the current machine (see cmpc-machine.lisp), but it wouldn't +;;; be useful because it only extends FFI types with ECL-specific +;;; types like :fixnum or :sse2. Another argument against such +;;; approach is semantic equivalence between interpreted and compiled +;;; versions of the special form. -- jd 2019-11-27 (defun c1-defcallback (args) (destructuring-bind (name return-type arg-list &rest body) args + (cond ((eql return-type nil) + (setf return-type :void)) + ((and (consp return-type) + (member (first return-type) '(* array))) + (setf return-type :pointer-void))) (let ((arg-types '()) (arg-type-constants '()) (arg-variables '()) @@ -29,74 +76,27 @@ (cmperr "Syntax error in CALLBACK form: C type is missing in argument ~A "i)) (push (first i) arg-variables) (let ((type (second i))) - (push (second i) arg-types) - (push (if (ffi::foreign-elt-type-p type) - (foreign-elt-type-code type) - (add-object type)) - arg-type-constants))) + (push type arg-types) + (push (foreign-elt-type-code type) arg-type-constants))) (push (list name c-name (add-object name) - return-type (reverse arg-types) (reverse arg-type-constants) call-type) + return-type + (foreign-elt-type-code return-type) + (reverse arg-types) + (reverse arg-type-constants) + call-type) *callbacks*) (c1expr `(progn - (defun ,name ,(reverse arg-variables) ,@body) - (si:put-sysprop ',name :callback - (ffi:c-inline () () :object - ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) - :one-liner t))))))) + (defun ,name ,(reverse arg-variables) ,@body) + (si:put-sysprop ',name :callback + (ffi:c-inline () () :object + ,(format nil "ecl_make_foreign_data(@':pointer-void,0,(void*)~a)" c-name) + :one-liner t))))))) -(defconstant +foreign-elt-type-codes+ - '((:char . "ECL_FFI_CHAR") - (:unsigned-char . "ECL_FFI_UNSIGNED_CHAR") - (:byte . "ECL_FFI_BYTE") - (:unsigned-byte . "ECL_FFI_UNSIGNED_BYTE") - (:short . "ECL_FFI_SHORT") - (:unsigned-short . "ECL_FFI_UNSIGNED_SHORT") - (:int . "ECL_FFI_INT") - (:unsigned-int . "ECL_FFI_UNSIGNED_INT") - (:long . "ECL_FFI_LONG") - (:unsigned-long . "ECL_FFI_UNSIGNED_LONG") - #+:uint16-t #+:uint16-t - (:int16-t . "ECL_FFI_INT16_T") - (:uint16-t . "ECL_FFI_UINT16_T") - #+:uint32-t #+:uint32-t - (:int32-t . "ECL_FFI_INT32_T") - (:uint32-t . "ECL_FFI_UINT32_T") - #+:uint64-t #+:uint64-t - (:int64-t . "ECL_FFI_INT64_T") - (:uint64-t . "ECL_FFI_UINT64_T") - #+:long-long #+:long-long - (:long-long . "ECL_FFI_LONG_LONG") - (:unsigned-long-long . "ECL_FFI_UNSIGNED_LONG_LONG") - (:pointer-void . "ECL_FFI_POINTER_VOID") - (:cstring . "ECL_FFI_CSTRING") - (:object . "ECL_FFI_OBJECT") - (:float . "ECL_FFI_FLOAT") - (:double . "ECL_FFI_DOUBLE") - (:long-double . "ECL_FFI_LONG_DOUBLE") - ;; complex floats - (:csfloat . "ECL_FFI_CSFLOAT") - (:cdfloat . "ECL_FFI_CDFLOAT") - (:clfloat . "ECL_FFI_CLFLOAT") - (:void . "ECL_FFI_VOID"))) - -(defun foreign-elt-type-code (type) - (let ((x (assoc type +foreign-elt-type-codes+))) - (unless x - (cmperr "~a is not a valid elementary FFI type" type)) - (cdr x))) - -(defun t3-defcallback (lisp-name c-name c-name-constant return-type +(defun t3-defcallback (lisp-name c-name c-name-constant return-type return-type-code arg-types arg-type-constants call-type &aux (return-p t)) - (cond ((member return-type '(nil :void)) - (setf return-p nil)) - ((ffi::foreign-elt-type-p return-type)) - ((and (consp return-type) - (member (first return-type) '(* array))) - (setf return-type :pointer-void)) - (t - (cmperr "DEFCALLBACK does not support complex return types such as ~A" - return-type))) + (when (eql return-type :void) + (setf return-p nil)) (let ((return-type-name (rep-type->c-name (ffi::%convert-to-arg-type return-type))) (fmod (case call-type ((:cdecl :default) "") @@ -104,15 +104,14 @@ (t (cmperr "DEFCALLBACK does not support ~A as calling convention" call-type))))) (wt-nl-h "static " return-type-name " " fmod c-name "(") - (wt-nl1 "static " return-type-name " " fmod c-name "(") - (loop for n from 0 - and type in arg-types - with comma = "" - do - (progn - (wt-h comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (wt comma (rep-type->c-name (ffi::%convert-to-arg-type type)) " var" n) - (setf comma ","))) + (wt-nl1 "static " return-type-name " " fmod c-name "(") + (loop with comma = "" + for n from 0 + for type in arg-types + for arg-type-name = (rep-type->c-name (ffi::%convert-to-arg-type type)) + do (wt-h comma arg-type-name " var" n) + (wt comma arg-type-name " var" n) + (setf comma ",")) (wt ")") (wt-h ");") (wt-nl-open-brace) @@ -124,17 +123,13 @@ (loop for n from 0 and type in arg-types and ct in arg-type-constants - do - (if (stringp ct) - (wt-nl "ecl_stack_frame_push(frame,ecl_foreign_data_ref_elt(&var" - n "," ct "));") - (wt-nl "ecl_stack_frame_push(frame,ecl_make_foreign_data(&var" - n "," ct ", (void*)" (ffi:size-of-foreign-type type) "));"))) + do (wt-nl "ecl_stack_frame_push(" + "frame,ecl_foreign_data_ref_elt(" "&var" n "," ct ")" + ");")) (wt-nl "aux = ecl_apply_from_stack_frame(frame," "ecl_fdefinition(" c-name-constant "));") (wt-nl "ecl_stack_frame_close(frame);") (when return-p - (wt-nl "ecl_foreign_data_set_elt(&output," - (foreign-elt-type-code return-type) ",aux);") + (wt-nl "ecl_foreign_data_set_elt(&output," return-type-code ",aux);") (wt-nl "return output;")) (wt-nl-close-brace))) diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp index 5f0f9afed..abec2466d 100644 --- a/src/cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -69,7 +69,6 @@ running the compiler. It may be updated by running ") (defvar *compiler-break-enable* nil) (defvar *compiler-in-use* nil) -(defvar *compiler-input*) (defvar *compiler-output1*) (defvar *compiler-output2*) @@ -235,9 +234,6 @@ slashes before special characters.") in the translated C/C++ file. Notice that it is unspecified where these lines are inserted, but the order is preserved") -(defvar *compile-time-too* nil) -(defvar *not-compile-time* nil) - (defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* ; or *temporary-objects* (defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* @@ -279,16 +275,6 @@ lines are inserted, but the order is preserved") ;;; | ( 'CLINES' string* ) ;;; | ( 'LOAD-TIME-VALUE' vv ) -;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). - -;;; FIXME: global-entries mechanism seems to be completely abandoned -;;; (always NIL). Either remove compiler code which uses it and remove -;;; variable itself or properly document it and use where -;;; applicable. -- jd 2019-05-07 -(defvar *global-entries* nil) - -(defvar *global-macros* nil) - (defvar *self-destructing-fasl* '() "A value T means that, when a FASL module is being unloaded (for instance during garbage collection), the associated file will be @@ -323,10 +309,8 @@ be deleted if they have been opened with LoadLibrary.") (*global-vars* nil) (*global-funs* nil) (*global-cfuns-array* nil) - (*global-entries* nil) (*undefined-vars* nil) (*top-level-forms* nil) - (*compile-time-too* nil) (*clines-string-list* '()) (*inline-blocks* 0) (*open-c-braces* 0) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index ae4620d38..954690682 100755 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -644,8 +644,7 @@ compiled successfully, returns the pathname of the compiled file" (cmpprogress "~&;;;~%;;; Compiling ~a." (namestring input-pathname)) - (let* ((eof '(NIL)) - (*compiler-in-use* *compiler-in-use*) + (let* ((*compiler-in-use* *compiler-in-use*) (*load-time-values* nil) ;; Load time values are compiled (output-file (apply #'compile-file-pathname input-file args)) (true-output-file nil) ;; Will be set at the end @@ -667,20 +666,11 @@ compiled successfully, returns the pathname of the compiled file" (when (probe-file "./cmpinit.lsp") (load "./cmpinit.lsp" :verbose *compile-verbose*)) - (data-init) - - (with-open-file (*compiler-input* *compile-file-pathname* - :external-format external-format) + (with-open-file (stream *compile-file-pathname* + :external-format external-format) (unless source-truename (setf (car ext:*source-location*) *compile-file-pathname*)) - (do* ((*compile-file-position* 0 (file-position *compiler-input*)) - (form (si::read-object-or-ignore *compiler-input* eof) - (si::read-object-or-ignore *compiler-input* eof))) - ((eq form eof)) - (when form - (setf (cdr ext:*source-location*) - (+ source-offset *compile-file-position*)) - (t1expr form)))) + (compiler-pass1 stream source-offset)) (cmpprogress "~&;;; End of Pass 1.") (setf init-name (compute-init-name output-file :kind @@ -800,8 +790,7 @@ after compilation." (with-compiler-env (compiler-conditions) (setf form (set-closure-env form lexenv *cmp-env-root*)) (print-compiler-info) - (data-init) - (t1expr form) + (compiler-pass1 form) (cmpprogress "~&;;; End of Pass 1.") (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t)) (compiler-pass2 c-pathname h-pathname data-pathname init-name @@ -897,8 +886,7 @@ from the C language code. NIL means \"do not create the file\"." #'(lambda (&rest args) (let ((*compiler-output1* *standard-output*)) (apply t3local-fun args)))) - (data-init) - (t1expr disassembled-form) + (compiler-pass1 disassembled-form) (ctop-write (compute-init-name "foo" :kind :fasl) (if h-file h-file "") (if data-file data-file "")) @@ -908,10 +896,29 @@ from the C language code. NIL means \"do not create the file\"." (when h-file (close *compiler-output2*))))) nil) +;;; FIXME source-offset and source-truename are used by swanks string +;;; compilation. Revisit if it is truly needed. SBCL deals with that +;;; using WITH-COMPILATION-UNIT macro what seems to be a much better +;;; place to customize the source location. -- jd 2019-11-25 +(defun compiler-pass1 (object &optional source-offset) + (data-init) + (if (streamp object) + (do* ((eof '(NIL)) + (*compile-file-position* 0 (file-position object)) + (form (si::read-object-or-ignore object eof) + (si::read-object-or-ignore object eof))) + ((eq form eof)) + (when form + (setf (cdr ext:*source-location*) + (+ source-offset *compile-file-position*)) + (t1expr form))) + (t1expr object))) + (defun compiler-pass2 (c-pathname h-pathname data-pathname init-name &key input-designator) (with-open-file (*compiler-output1* c-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create + :if-exists :supersede) (wt-comment-nl "Compiler: ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) #-ecl-min (multiple-value-bind (second minute hour day month year) @@ -921,7 +928,8 @@ from the C language code. NIL means \"do not create the file\"." (wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type))) (wt-comment-nl "Source: ~A" input-designator) (with-open-file (*compiler-output2* h-pathname :direction :output - :if-does-not-exist :create :if-exists :supersede) + :if-does-not-exist :create + :if-exists :supersede) (wt-nl1 "#include " *cmpinclude*) (ctop-write init-name h-pathname data-pathname) (terpri *compiler-output1*) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index e0e4cda3f..30389867d 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -31,12 +31,14 @@ (*current-form* form) (*first-error* t) (*setjmps* 0)) + (setq form (chk-symbol-macrolet form)) (when (consp form) (let ((fun (car form)) (args (cdr form)) fd) (when (member fun *toplevel-forms-to-print*) (print-current-form)) (cond - ((consp fun) (t1ordinary form)) + ((consp fun) + (t1ordinary form)) ((not (symbolp fun)) (cmperr "~s is illegal function." fun)) ((eq fun 'QUOTE) @@ -93,8 +95,7 @@ (defun emit-local-funs () (declare (si::c-local)) ;; Local functions and closure functions - (do ((*compile-time-too* nil) - (*compile-toplevel* nil)) + (do ((*compile-toplevel* nil)) ;; repeat until t3local-fun generates no more ((eq *emitted-local-funs* *local-funs*)) ;; scan *local-funs* backwards @@ -199,10 +200,6 @@ (wt-nl-h "#define VM " (data-permanent-storage-size)) (wt-nl-h "#define VMtemp " (data-temporary-storage-size))))) - ;;; Global entries for directly called functions. - (dolist (x *global-entries*) - (apply 'wt-global-entry x)) - (wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ") (loop for (name setf-vv name-vv) in *setf-definitions* do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);")) @@ -272,12 +269,13 @@ (execute-flag nil)) (dolist (situation (car args)) (case situation - ((CL:LOAD :LOAD-TOPLEVEL) (setq load-flag t)) - ((CL:COMPILE :COMPILE-TOPLEVEL) (setq compile-flag t)) + ((CL:LOAD :LOAD-TOPLEVEL) + (setq load-flag t)) + ((CL:COMPILE :COMPILE-TOPLEVEL) + (setq compile-flag t)) ((CL:EVAL :EXECUTE) - (if *compile-toplevel* - (setq compile-flag (or *compile-time-too* compile-flag)) - (setq execute-flag t))) + (unless *compile-toplevel* + (setq execute-flag t))) (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal." situation)))) (cond ((not *compile-toplevel*) @@ -434,46 +432,6 @@ do (wt comma "CLV" i) finally (wt ";")))) -(defun wt-global-entry (fname cfun arg-types return-type) - (when (and (symbolp fname) (si:get-sysprop fname 'NO-GLOBAL-ENTRY)) - (return-from wt-global-entry nil)) - (wt-comment-nl "global entry for the function ~a" fname) - (wt-nl "static cl_object L" cfun "(cl_narg narg") - (wt-nl-h "static cl_object L" cfun "(cl_narg") - (do ((vl arg-types (cdr vl)) - (lcl (1+ *lcl*) (1+ lcl))) - ((endp vl) (wt1 ")")) - (declare (fixnum lcl)) - (wt1 ", cl_object ") (wt-lcl lcl) - (wt-h ", cl_object")) - (wt-h1 ");") - (wt-nl-open-brace) - (when (compiler-check-args) - (wt-nl "_ecl_check_narg(" (length arg-types) ");")) - (wt-nl "cl_env_copy->nvalues = 1;") - (wt-nl "return " (ecase return-type - (FIXNUM "ecl_make_fixnum") - (CHARACTER "CODE_CHAR") - (DOUBLE-FLOAT "ecl_make_double_float") - (SINGLE-FLOAT "ecl_make_single_float") - (LONG-FLOAT "ecl_make_long_float")) - "(LI" cfun "(") - (do ((types arg-types (cdr types)) - (n 1 (1+ n))) - ((endp types)) - (declare (fixnum n)) - (wt (case (car types) - (FIXNUM "fix") - (CHARACTER "ecl_char_code") - (DOUBLE-FLOAT "df") - (SINGLE-FLOAT "sf") - (LONG-FLOAT "ecl_long_float") - (otherwise "")) "(") - (wt-lcl n) (wt ")") - (unless (endp (cdr types)) (wt ","))) - (wt "));") - (wt-nl-close-many-braces 0)) - (defun rep-type (type) (case type (FIXNUM "cl_fixnum ") @@ -483,9 +441,7 @@ (otherwise "cl_object "))) (defun t1ordinary (form) - (when *compile-time-too* (cmp-eval form)) - (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (let ((*compile-toplevel* nil)) (add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form))))) (defun p1ordinary (c1form assumptions form) @@ -796,10 +752,7 @@ ;;; (defun t1fset (args) (let ((form `(si::fset ,@args))) - (when *compile-time-too* - (cmp-eval form)) - (let ((*compile-toplevel* nil) - (*compile-time-too* nil)) + (let ((*compile-toplevel* nil)) (add-load-time-values (c1fset form))))) (defun c1fset (form) diff --git a/src/cmp/notes.org b/src/cmp/notes.org new file mode 100644 index 000000000..4926bbf79 --- /dev/null +++ b/src/cmp/notes.org @@ -0,0 +1,708 @@ + +* ECL compiler + +ECL's comipler source code may be little hard to read. It relies +heavily on global variables and the code has grown over many years of +fixes and improvements. These notes are meant to serve the purpose of +a guide (not a reference manual or a documentation). If you notice +that they are not up to date then please submit a patch with +corrections. + +** Abstract syntax tree + +Syntax tree nodes are represented as instances of the ~c1form~ +structure. Each node has a slot ~name~ which is a symbol denoting the +operator and information about the file and position in it. + +Operators are dispatched to functions with appropriate tables +associated with a functionality (i.e ~*p1-dispatch-table*~ is a +dispatch table for type propagators associated with ~c1form~'s). + +** References + +Object references are used for numerous optimizations. They are +represented as instances of ~ref~ structure descendants: + +- var :: variable reference +- fun :: function reference +- blk :: block reference (block/return) +- tag :: tag reference (tagbody/go) + +Each reference has an identifier, number of references, flags for +cross-closure-boundary and cross-local-function-boundary references +and a list of nodes (c1forms) which refer to the object. + +** Compilation algorithm (simlified) + +When compiling a file (simplified ovierview): + +First pass: + +1. Check if the file exists and that we can perform the compilation +2. Estabilish the compilation environment +3. Load ~cmpinit.lsp~ if present in the same directory +4. Initialize a data section and construct the AST (~compiler-pass1~) + +Second pass: + +1. Compute initialization function name (entry point of the object) +2. Propagate types through the AST +2. Compile AST to a C source files ~.c~ and ~.eclh~ (~compiler-pass2~) +3. Dump a data segment in a ~.data~ file (symbol ~compiler_data_text~) +4. Compile artifacts with the C compiler (~compiler-cc~ and ~bundle-cc~)) + +*** compiler-pass1 + +1. Initialize a data section + +Data section contains permanent and temporary objects which are later +serialized in a data segment of the complaition artifacts after the +second pass. Objects put in data section are constants, symbols, +~load-time-value~'s etc. The same object may be added few times, then +it is stored as a location. Not object types can be dumped to C file. + +2. Construct the AST + +Each form which is read is passed to t1expr creates a ~c1form~ which +are stored in ~*top-level-forms*~ which are later used in the second +pass. ~c1form~ is created as follows (simplified pseudocode): + +#+BEGIN_SRC common-lisp + (defun t1expr* (form) + (setq form (maybe-expand-symbol-macro form)) + (when (atom form) + ;; ignore the form + (return)) + (destructuring-bind (op args) form + (typecase op + (cons + (t1ordinary form)) + ((not symbol) + (error "illegal function")) + ((eq quote) + ;; should we ignore the form(?) + (t1ordinary 'NIL)) + (t1-dispatch-entry + (top-level-dispatch form)) + (c1-dispatch-entry + (not-top-level-dispatch form)) + (expandable-compiler-macro + (add 'macroexpand *current-toplevel-form*) + (t1expr* (expand-macro form))) + (expandable-macro + (add 'macroexpand *current-toplevel-form*) + (t1expr* (expand-macro form))) + (otherwise + (t1ordinary form))))) +#+END_SRC + +Forms are processed recursively with appropriate operator +handlers. Funcations named ~t1xxx~ are a top level form handlers while +~c1xxx~ are handlers for the rest. When operator is not special it is +processed according to normal rules i.e with ~c1call~. + +Function ~t1ordinary~ handles top-level forms which do not have +special semantics associated with them by binding top-levelness flag +to NIL and adding a c1form with a name ~ordinary~ and storing result +of ~(c1expr form)~ in load-time values. Top level forms may have side +effects (i.e registering a macro in a global compiler environment). + +Function ~c1expr~ is used to handle forms which are not +top-level. Dispatched operator handler may eliminate dead code, +perform constant folding and propagate constants and rewrite the form +which is processed again. Handler may modify the compiler environment +(i.e register a local function or a local variable) and add new +objects to a data section. Already created c1forms may be updated i.e +to note that there is a cross-closure reference. + +*** compiler-pass2 + +Second pass is responsible for producing files which are then compiled +by the C compiler. For top level forms we have ~t2xxx~ handlers and +for the rest ~c2xxx~ handlers. Additionally there are other helper +tables (~p1xxx~ for type propagation and location dispatch tables +~set-loc~ and ~wt-loc~ with varying handler names). + +#+BEGIN_SRC lisp + (defun pass2 () + (produce-headers) + (eclh/produce-data-section-declarations) + (with-initialization-code () ; this is put at the end of c file + (include-data-file) + (produce-initialize-cblock) + (produce-setf-function-definitions) + (do-type-propagation *top-level-forms*) + ;; compiler-phase "t2" starts now + ;; + ;; This part is tricky. When we emit top-level form part of it + ;; lands in the c-file before the initialization code (C function + ;; definitions) and part is put in the initialization code. + (emit-top-level-forms *make-forms*) + (emit-top-level-forms *top-level-forms*)) + (eclh/produce-data-segment-declarations) + (eclh/produce-setf-function-definers) ; should be inlined in c file? + (eclh/add-static-constants) ; CHECKME never triggered? + (eclh/declare-c-funciton-table) ; static table with function data + ;; compiler-phase "t3" starts now + (eclh/declare-callback-functions) ; calls t3-callback + (data/dump-data-section)) + + (defun emit-top-level-form (form) + (with-init () + (emit (t2expr form))) + (do-local-funs (fun) + ;; t3local-fun may add new local funs to process. + (emit (t3local-fun fun)))) +#+END_SRC + +**** Example output + +Example output in pseudocode follows. I've put some comments to +indicate potential issues and improvement opportunities. + +- .eclh :: static data, declarations and symbol mappings +#+BEGIN_SRC c (.eclh pseudocode) + static cl_object *VV; /* declare data section */ + static cl_object Cblock; + + #define VM size_of_data_permanent_storage; + #define VMtemp size_of_data_temporary_storage; + + /* Declare functions in this file. They are declared static and hold + in Cblock to assure that we can recompile the fasl and load it. */ + static cl_object L1ordinary_function(cl_object , cl_object ); + static cl_object LC2foobar(cl_object , cl_object ); + static cl_object LC3__g0(cl_object , cl_object ); + + /* In safe code we always go through ecl_fdefinition and then this + macro definition expands to nothing. */ + #define ECL_DEFINE_SETF_FUNCTIONS \\ + VV[10]=ecl_setf_definition(VV[11],ECL_T); \\ + VV[12]=ecl_setf_definition(VV[13],ECL_T); + + /* Statically defined constants. + + XXX I'm not sure how to trigger constant builders. Needs + investigation if it is not a dead code, and if so whether we should + resurrect it or remove. */ + + /* exported lisp functions -- installed in Cblock */ + #define compiler_cfuns_size 1 + static const struct ecl_cfunfixed compiler_cfuns[] = { + /*t,m,narg,padding,name=function-location,block=name-location,entry,entry_fixed,file,file_position*/ + {0,0,2,0,ecl_make_fixnum(6),ecl_make_fixnum(0),(cl_objectfn)L1ordinary_function,NULL,ECL_NIL,ecl_make_fixnum(23)}, + }; + + /* callback declarations (functions defined with defcallback). */ + #include + static int ecl_callback_0(int var0,int var1); +#+END_SRC + +- .data :: data segment +#+BEGIN_SRC c (.data pseudocode) + static const struct ecl_base_string compiler_data_text1[] = { + (int8_t)t_base_string, 0, ecl_aet_bc, 0, + ECL_NIL, (cl_index)1065, (cl_index)1065, + (ecl_base_char*) + "common-lisp-user::make-closure common-lisp-user::ordinary-function common-lisp-u" + "ser::+ordinary_constant+ common-lisp-user::*foobar* common-lisp-user::foobar :de" + "lete-methods clossy-package::bam 0 0 si::dodefpackage clos::install-method clos:" + ":associate-methods-to-gfun \"CL-USER\" ((optimize (debug 1))) (defun common-lisp-u" + "ser::make-closure) (#1=#P\"/home/jack/test/foobar.lisp\" . 55) (defun common-lisp-" + "user::ordinary-function) (#1# . 132) (common-lisp-user::a common-lisp-user::b) 4" + "2.32 (defconstant common-lisp-user::+ordinary_constant+) (#1# . 175) (defvar com" + "mon-lisp-user::*foobar*) (#1# . 216) (defun common-lisp-user::foobar) (#1# . 237" + ") \"CLOSSY-PACKAGE\" (\"CL\") (\"BAM\" \"GENERIC-FUNCTION\") (defgeneric generic-functio" + "n) (#1# . 451) (clossy-package::a clossy-package::b) (defmethod generic-function" + " (clossy-package::a real) (clossy-package::b real)) (real real) (defmethod gener" + "ic-function (clossy-package::a integer) (clossy-package::b integer)) (integer in" + "teger) (defclass clossy-package::bam) (#1# . 582) ((:initform 42 :initargs (:a) " + ":name clossy-package::a))" }; + + static const cl_object compiler_data_text[] = { + (cl_object)compiler_data_text1, + NULL}; +#+END_SRC + +- .c :: function definitions and the initialization code +#+BEGIN_SRC c (.c pseudocode) + #include + #include "/absolute/path/to/.eclh" + + /* Normal functions are defined with DEFUN. Local functions may be + lambdas, closures, methods, callbacks etc. + + XXX callback function implementations should be inlined to avoid + indirection. + + XXX method function names are named like LCn__g0 and on lisp side + they have names like g0 -- gensymed part of the name should be + produced from the generic function name for easier debugging. */ + + /* normal function definitions */ + static cl_object L1fun (cl_object v1a, cl_object v2b) { /*...*/ } + /* local function definitions */ + static cl_object LC2__g0 (cl_object v1a) { /* method */ } + static cl_object LC3__g0 (cl_narg narg, ...) { /* closure */ } + static cl_object LC4foobar (cl_object v1a, cl_object v2b) { /* callback */ } + + /* callbacks */ + static int ecl_callback_0 (int var0, int var1) { /* calls LC2foobar */ } + + #include "/absolute/path/to/.data" + ECL_DLLEXPORT void init_fas_CODE(cl_object flag) { + /* Function is designed to work in two passes. */ + if (flag != OBJNULL) { + /* The loader passes a cblock as flag for us to initialize. */ + Cblock = flag->cblock; + flag->cblock.data = VV; + flag->cblock.data_text = compiler_data_text; + /* ... */ + return; + } + /* The loader initializes the module (calls READ on data segment + elements and initializes cblock.data with results, then installs + functions and their source information. */ + + /* 2. Execute top level code. */ + VVtemp = Cblock->cblock.temp_data; + ECL_DEFINE_SETF_FUNCTIONS; + + /* Note that mere annotation in a simple file requires plenty of + function calls so that impacts FASL load time. We should make + annotations part of the objects themself (instead of keeping a + central registry), then maybe we could keep this data static. */ + + si_select_package(VVtemp[0]); + (cl_env_copy->function=(ECL_SYM("MAPC",545)->symbol.gfdef))->cfun.entry(2, ECL_SYM("PROCLAIM",668), VVtemp[1]) /* MAPC */; + ecl_function_dispatch(cl_env_copy,ECL_SYM("ANNOTATE",1823))(4, VV[0], ECL_SYM("LOCATION",1829), VVtemp[2], VVtemp[3]) /* ANNOTATE */; + ecl_function_dispatch(cl_env_copy,ECL_SYM("ANNOTATE",1823))(4, VV[0], ECL_SYM("LAMBDA-LIST",1000), ECL_NIL, ECL_NIL) /* ANNOTATE */; + ecl_cmp_defun(VV[7]); /* MAKE-CLOSURE */ + /* ... */ + si_select_package(VVtemp[14]); + + /* XXX defgeneric should be compiled. */ + (cl_env_copy->function=(ECL_SYM("ENSURE-GENERIC-FUNCTION",944)->symbol.gfdef))->cfun.entry(5, ECL_SYM("GENERIC-FUNCTION",947), VV[5], ECL_T, ECL_SYM("LAMBDA-LIST",1000), VVtemp[19]) /* ENSURE-GENERIC-FUNCTION */; + clos_load_defclass(VV[6], ECL_NIL, VVtemp[26], ECL_NIL); + /* ... */ + } +#+END_SRC + +Generic functions are not compiled. + +** Representation types +Compilation target machine is described in terms of types supported by +the target compiler. ~+representation-types+~ cover primitives types +which are representable in C (:byte, :fixnum, :float-sse-pack, :bool, +:pointer-void etc.). Each type has a corresponding Lisp type, C type +and ways to convert between Lisp and C types (a separate column shows +how to perform an unsafe convertion on unboxed values). List is +ordered from the most specific to the least specific. + +To describe a concreete machine two variables are used: +~+all-machines-c-types+~ containing common types for all C compilers +(without integers) and ~+this-machine-c-types+~ adding integers and +types which vary between C compilers (i.e ~long long int~). Optionally +each type has information about number of bits used (for bit +fiddling), that information should be kept separate (imo). Variable +~*default-machine*~ use constructed from these both +tables. Alternative machine representations may be created for cross +compilation. + +Each representation type is represented by an instance of a structure +~rep-type~. That information is used when the C code is generated to +manipulate data of certain type. + +** Environments + +*** Compilation environment +*** The Global environment +*** Dynamic environments +*** Lexical environments +**** Debug Lexical Environment + +Environment objects + +http://www.lispworks.com/documentation/HyperSpec/Body/03_aa.htm + +** Loading FASL files + +** Cross compilation +* old notes +** si:cmp-env-register-macrolet should be part of cmpenv-api +** extract type propagation pass, see 7e8d0985155 + +** cmpdata, cmpdata-bk +*** Frontend +vv structure is a single data section entry. We have two data stores – +permanent and temporary. + +- vv-location :: index in data-store (a number) +- vv-permanent-p :: store flag (t -> permanent, nil -> temporary) +- vv-used-p :: flag indicating if entry is referenced, if not it gets + optimized away (same goes for *load-objects*). To keep indexing + and data size intact we put 0 in place of optimized objects. +- vv-value :: holds the entry actual value + +- *load-objects* :: collection of all objects which are created by a + lisp form – we don't include them in datasection. We need to keep + track of them to filter them out. + +- data-size :: size of data stores combined + +- data-init :: initalizes data stores. If filename parameter is + present, then it objects are read from the file. Otherwise store + is empty. + +- data-dump-array :: dumps data stores + +*** Backend +- add-static-constant :: called from data frontend. +- data-c-dump :: called from cmpmain, creates data section in a + separate C file +- wt-vv :: used by cmploc, accesses element in data section +- set-vv :: used in cmploc, modifies element in data section + +** pass1 extract 1st attempt: +#+BEGIN_SRC lisp + (defpackage ecl-cmp/int + (:use #:ffi #:ext #:cl) + (:export + ;; BACKEND REFERENCES IN FRONTEND!!! + #:lisp-type->rep-type #:c1make-var #:check-vref #:lisp-type-p + #:rep-type->lisp-type #:expand-type-assertion #:machine-c-type-p + ;; opts (SHOULDN'T BE) + #:constant-value-p + ;; things which should be local to the module + #:*compile-toplevel* + #:*top-level-forms* ; referenced in cmp1top, bound in cmptop (and not used?) + #:*load-time-values* ; referenced in cmp1top, bound in cmpmain (and not used?) + #:clos-compiler-macro-expand ; used only in pass1 + #:*optimizable-constants* ; used only in pass1 and cmpopt-constant + #:*setjmps* ; local to pass1 + #:*use-c-global* ; local to pass1 + #:*clines-string-list* ; shared by ffi of both passses (and 1ct) + #:c1body ; should be brought back to cmpenv-declaim! + #:*next-cfun* ; used only in cmp1lam, but part of cmpenv + #:lisp-to-c-name ; used in cmpvar, cmp1lam + ;; common utilities + #:make-dispatch-table #:check-args-number #:print-current-form + ;; cmputil (conditions) + #:cmpck #:cmpassert #:cmperr #:cmpdebug #:cmpnote + ;; types (arith and propagation) + #:object-type #:trivial-type-p #:values-type-and #:values-type-primary-type + #:type-and #:type-or #:values-type-or #:valid-type-specifier + #:propagate-types + ;; locations + #:add-object #:add-symbol #:loc-in-c1form-movable-p + #:*make-forms* + ;; internal representation + #:call-global #:ordinary #:var #:fmla-and #:fmla-or #:fmla-not + #:locals #:stack-push-values #:with-stack #:call-local + ;; + #:make-c1form* #:*current-toplevel-form* + #:c1form-p #:c1form-type + #:c1form-primary-type + #:c1form-name + #:c1form-constant-p + #:c1form-arg + #:c1form-args + #:c1form-replace-with + #:c1form-side-effects + #:c1form-volatile + #:delete-c1forms + #:and-form-type ; not sure if it belogns here + #:local-function-ref ; XXX: defined in env + #:*current-function* + #:make-fun + #:fun-name + #:fun-parent + #:fun-lambda-expression + #:fun-cmp-env + #:fun-global + #:fun-cfun + #:fun-exported + #:fun-closure + #:fun-minarg + #:fun-maxarg + #:fun-description + #:fun-no-entry + #:fun-referenced-funs + #:fun-child-funs + #:fun-lambda + #:fun-var + #:fun-ref + #:fun-referenced-vars + #:fun-referencing-funs + #:add-to-fun-referenced-vars + #:add-to-fun-referenced-funs + #:update-fun-closure-type + #:get-arg-types + #:make-var + #:make-global-variable + #:var-type + #:var-ignorable + #:var-p + #:var-ref + #:var-ref-ccb + #:var-ref-clb + #:var-kind + #:var-name + #:var-loc + #:var-set-nodes + #:var-read-nodes + #:var-functions-reading + #:var-functions-setting + #:var-read-forms + #:var-changed-in-form-list + #:update-variable-type ; ref only in 1let + #:global-var-p + #:add-to-set-nodes + #:add-to-set-nodes-of-var-list + #:add-to-read-nodes + #:add-to-read-nodes-of-var-list + #:delete-from-set-nodes + #:delete-from-read-nodes + #:make-blk + #:blk-ref-ccb + #:blk-ref-clb + #:blk-ref + #:blk-type + #:make-tag + #:tag-name + #:tag-p + #:tag-var + #:tag-ref + ;; environment + #:*global-funs* ; in cmpglobals + #:*cmp-env* #:cmp-env-root #:cmp-env-copy #:cmp-env-mark + #:cmp-env-search-macro + #:cmp-env-search-block + #:cmp-env-register-function + #:cmp-env-register-global-macro + #:cmp-env-register-symbol-macro + #:cmp-env-search-symbol-macro + #:cmp-env-register-block + #:cmp-env-search-var + #:cmp-env-declare-special + #:cmp-env-new-variables + #:cmp-env-register-tag + #:cmp-env-search-tag + #:get-return-type + #:inline-possible ; queries for notinline decl + #:declared-inline-p + #:function-may-change-sp + #:function-may-have-side-effects + #:special-variable-p + #:push-vars + #:add-one-declaration + #:check-arguments-type + #:variable-type-in-env + #:alien-declaration-p + #:get-local-return-type + #:get-local-arg-types + #:policy-check-arguments-type #:policy-type-assertions #:policy-evaluate-forms + #:policy-declaration-name-p #:policy-debug-ihs-frame + ;; first pass interface + #:t1expr #:c1expr #:c1args* #:cmp-eval)) + + (defpackage ecl-cmp/pass1 + (:use #:ffi #:ext #:cl #:c #:ecl-cmp/int)) + + (defpackage "C" + (:nicknames "COMPILER") + (:use "FFI" "EXT" "CL" #:ecl-cmp/int) + (:shadow #:disassemble + #:compile + #:compile-file + #:compile-file-pathname + ;;; These functions will be common in our frontend + ;; #:proclaim #:declaim #:with-compilation-unit + ) + (:export "*COMPILER-BREAK-ENABLE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*COMPILER-FEATURES*" + "*CC*" + "*CC-OPTIMIZE*" + "*USER-CC-FLAGS*" + "*USER-LD-FLAGS*" + "*SUPPRESS-COMPILER-MESSAGES*" + "BUILD-ECL" + "BUILD-PROGRAM" + "BUILD-FASL" + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" + "*SUPPRESS-COMPILER-MESSAGES*" + "INSTALL-C-COMPILER" + "UPDATE-COMPILER-FEATURES") + (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" + "*COMPILER-CONSTANTS*" "COMPILER-LET")) +#+END_SRC +** TODO be explicit in dispatch symbol packages (i.e cl:progn) +** TODO 'UNWIND-PROTECT tag should be made a keyword +** TODO use package agnostic marks '(CB LB CLB CCB UNWIND-PROTECT CLOSURE) +** TODO declared-inline-p, inline-possible and declared-notinline-p should have one common interface +** cmpdata should be merged with cmpwt (which has only data accessors) +** TODO wt-structure-ref doesn't exist! +This is a removal from CLOS merge probably, fixme! + +** TODO some compiler macros belong to the backend! + +** generic function potential optimizations +*** ecl has one dispatcher and one cache for *all* generic functions - many misses +*** each generic function needs to have its own cache and dispatcher (for instance if there is one method it may be way faster) +*** effective method may be compiled into one function unless one of the methods is a closure (or has eql specializer) + +** Lambdas +#+BEGIN_SRC lisp +;;; lambda expression + +;;; During Pass1, a lambda-list +;;; +;;; ( { var }* +;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] +;;; [ &rest var ] +;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* +;;; [&allow-other-keys]] +;;; [ &aux {var | (var [initform])}*] +;;; ) +;;; +;;; is transformed into +;;; +;;; ( ( { var }* ) ; required +;;; ( { var initform svar }* ) ; optional +;;; { var | nil } ; rest +;;; allow-other-keys-flag +;;; ( { kwd-vv-index var initform svar }* ) ; key +;;; ) +;;; +;;; where +;;; svar: NIL ; means svar is not supplied +;;; | var +;;; +;;; &aux parameters will be embedded into LET*. +;;; +;;; c1lambda-expr receives +;;; ( lambda-list { doc | decl }* . body ) +;;; and returns +;;; ( lambda info-object lambda-list' doc body' ) +;;; +;;; Doc is NIL if no doc string is supplied. +;;; Body' is body possibly surrounded by a LET* (if &aux parameters are +;;; supplied) and an implicit block. +#+END_SRC + +** cmp-env- interface + +*** cmppolicy.lsp:cmp-env-policy :local: +*** cmppolicy.lsp:cmp-env-add-optimizations :internal: +*** cmppolicy.lsp:cmp-env-optimization :external: +*** cmppolicy.lsp:add-default-optimizations :internal: + +*** cmpenv-api.lsp:cmp-env-root :external: +*** cmpenv-api.lsp:cmp-env-copy :external: +*** cmpenv-api.lsp:cmp-env-cleanups :unused: +*** cmpenv-api.lsp:cmp-env-register-var :used: +*** cmpenv-api.lsp:cmp-env-declare-special :used: +*** cmpenv-api.lsp:cmp-env-add-declaration :internal: +*** cmpenv-api.lsp:cmp-env-extend-declaration :internal: + +*** cmpenv-api.lsp:cmp-env-register-function :used: +*** cmpenv-api.lsp:cmp-env-register-global-macro :used: +*** cmpenv-api.lsp:cmp-env-register-macro :used: +*** cmpenv-api.lsp:cmp-env-register-ftype :internal: +*** cmpenv-api.lsp:cmp-env-register-symbol-macro :external: +*** cmpenv-api.lsp:cmp-env-register-block :used: +*** cmpenv-api.lsp:cmp-env-register-tag :used: +*** cmpenv-api.lsp:cmp-env-register-cleanup :unused: + +*** cmpenv-api.lsp:cmp-env-search-function :external: +*** cmpenv-api.lsp:cmp-env-search-variables :local: +*** cmpenv-api.lsp:cmp-env-search-block :used: +*** cmpenv-api.lsp:cmp-env-search-tag :used: +*** cmpenv-api.lsp:cmp-env-search-symbol-macro :external: +*** cmpenv-api.lsp:cmp-env-search-var :external: +*** cmpenv-api.lsp:cmp-env-search-macro :used: +*** cmpenv-api.lsp:cmp-env-search-ftype :internal: + +*** cmpenv-api.lsp:cmp-env-mark :external: +*** cmpenv-api.lsp:cmp-env-new-variables :used: +*** cmpenv-api.lsp:cmp-env-search-declaration :internal: + +** cmpenv-fun.lsp +*** proclaim-function :external: +*** add-function-declaration :internal: +*** get-arg-types :external: +*** get-return-type :external: +*** get-local-arg-types :used: +*** get-local-return-type :used: +*** get-proclaimed-narg :external: +*** declare-inline :internal: +*** declare-notinline :internal: +*** proclaim-inline :internal: +*** proclaim-notinline :internal: +*** declared-inline-p :external: +*** declared-notinline-p :local: +*** inline-possible :external: +*** maybe-install-inline-function :hook: + +** cmpform +*** c1form-local-type :info:unused: +*** c1form-local-vars :info: +*** c1form-sp-change :info: +*** c1form-volatile :info: + +*** c1form-name +*** c1form-parents :local: +*** c1form-env +*** c1form-args +*** c1form-side-effects +*** c1form-form +*** c1form-toplevel-form +*** c1form-file +*** c1form-file-position + +*** print-c1form +*** make-c1form +*** make-c1form* +*** c1form-arg +*** c1form-volatile* :backend: +*** c1form-primary-type +*** location-primary-type (same as above) + +*** find-form-in-node-list +*** add-form-to-node-list +*** delete-form-from-node-list +used only in cmpvar +*** traverse-c1form-tree +*** c1form-movable-p +*** c1form-values-number +*** c1form-single-valued-p +*** with-c1form-env +*** relocate-parents-list :local: +*** c1form-replace-with +*** delete-c1forms +*** c1form-constant-p + +* khm + +** TODO try to investigate how to produce statically defined constants +** TODO analyze foobar.lisp output and describe it + +* links +** Nimble type inferencer +http://home.pipeline.com/~hbaker1/TInference.html +** Gccemacs writeup (simialar compiler to ecl) +http://akrl.sdf.org/gccemacs.html diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index d4e289e2c..670797bfa 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -761,7 +761,11 @@ Loads a foreign library." (values-list name) (values name :default)) (let ((arg-types (mapcar #'second arg-desc)) - (arg-names (mapcar #'first arg-desc))) + (arg-names (mapcar #'first arg-desc)) + (ret-type (typecase ret-type + ((member nil :void) :void) + ((cons (member * array)) :pointer-void) + (otherwise ret-type)))) `(si::make-dynamic-callback #'(ext::lambda-block ,name ,arg-names ,@body) ',name ',ret-type ',arg-types ,call-type))) diff --git a/src/newcmp/notes.org b/src/newcmp/notes.org deleted file mode 100644 index 4760adb18..000000000 --- a/src/newcmp/notes.org +++ /dev/null @@ -1,369 +0,0 @@ - -** si:cmp-env-register-macrolet should be part of cmpenv-api -** extract type propagation pass, see 7e8d0985155 - -** cmpdata, cmpdata-bk -*** Frontend -vv structure is a single data section entry. We have two data stores – -permanent and temporary. - -- vv-location :: index in data-store (a number) -- vv-permanent-p :: store flag (t -> permanent, nil -> temporary) -- vv-used-p :: flag indicating if entry is referenced, if not it gets - optimized away (same goes for *load-objects*). To keep indexing - and data size intact we put 0 in place of optimized objects. -- vv-value :: holds the entry actual value - -- *load-objects* :: collection of all objects which are created by a - lisp form – we don't include them in datasection. We need to keep - track of them to filter them out. - -- data-size :: size of data stores combined - -- data-init :: initalizes data stores. If filename parameter is - present, then it objects are read from the file. Otherwise store - is empty. - -- data-dump-array :: dumps data stores - -*** Backend -- add-static-constant :: called from data frontend. -- data-c-dump :: called from cmpmain, creates data section in a - separate C file -- wt-vv :: used by cmploc, accesses element in data section -- set-vv :: used in cmploc, modifies element in data section - -** pass1 extract 1st attempt: -#+BEGIN_SRC lisp - (defpackage ecl-cmp/int - (:use #:ffi #:ext #:cl) - (:export - ;; BACKEND REFERENCES IN FRONTEND!!! - #:lisp-type->rep-type #:c1make-var #:check-vref #:lisp-type-p - #:rep-type->lisp-type #:expand-type-assertion #:machine-c-type-p - ;; opts (SHOULDN'T BE) - #:constant-value-p - ;; things which should be local to the module - #:*compile-toplevel* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*compile-time-too* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*top-level-forms* ; referenced in cmp1top, bound in cmptop (and not used?) - #:*load-time-values* ; referenced in cmp1top, bound in cmpmain (and not used?) - #:clos-compiler-macro-expand ; used only in pass1 - #:*optimizable-constants* ; used only in pass1 and cmpopt-constant - #:*setjmps* ; local to pass1 - #:*use-c-global* ; local to pass1 - #:*clines-string-list* ; shared by ffi of both passses (and 1ct) - #:c1body ; should be brought back to cmpenv-declaim! - #:*next-cfun* ; used only in cmp1lam, but part of cmpenv - #:lisp-to-c-name ; used in cmpvar, cmp1lam - ;; common utilities - #:make-dispatch-table #:check-args-number #:print-current-form - ;; cmputil (conditions) - #:cmpck #:cmpassert #:cmperr #:cmpdebug #:cmpnote - ;; types (arith and propagation) - #:object-type #:trivial-type-p #:values-type-and #:values-type-primary-type - #:type-and #:type-or #:values-type-or #:valid-type-specifier - #:propagate-types - ;; locations - #:add-object #:add-symbol #:loc-in-c1form-movable-p - #:*make-forms* - ;; internal representation - #:call-global #:ordinary #:var #:fmla-and #:fmla-or #:fmla-not - #:locals #:stack-push-values #:with-stack #:call-local - ;; - #:make-c1form* #:*current-toplevel-form* - #:c1form-p #:c1form-type - #:c1form-primary-type - #:c1form-name - #:c1form-constant-p - #:c1form-arg - #:c1form-args - #:c1form-replace-with - #:c1form-side-effects - #:c1form-volatile - #:delete-c1forms - #:and-form-type ; not sure if it belogns here - #:local-function-ref ; XXX: defined in env - #:*current-function* - #:make-fun - #:fun-name - #:fun-parent - #:fun-lambda-expression - #:fun-cmp-env - #:fun-global - #:fun-cfun - #:fun-exported - #:fun-closure - #:fun-minarg - #:fun-maxarg - #:fun-description - #:fun-no-entry - #:fun-referenced-funs - #:fun-child-funs - #:fun-lambda - #:fun-var - #:fun-ref - #:fun-referenced-vars - #:fun-referencing-funs - #:add-to-fun-referenced-vars - #:add-to-fun-referenced-funs - #:update-fun-closure-type - #:get-arg-types - #:make-var - #:make-global-variable - #:var-type - #:var-ignorable - #:var-p - #:var-ref - #:var-ref-ccb - #:var-ref-clb - #:var-kind - #:var-name - #:var-loc - #:var-set-nodes - #:var-read-nodes - #:var-functions-reading - #:var-functions-setting - #:var-read-forms - #:var-changed-in-form-list - #:update-variable-type ; ref only in 1let - #:global-var-p - #:add-to-set-nodes - #:add-to-set-nodes-of-var-list - #:add-to-read-nodes - #:add-to-read-nodes-of-var-list - #:delete-from-set-nodes - #:delete-from-read-nodes - #:make-blk - #:blk-ref-ccb - #:blk-ref-clb - #:blk-ref - #:blk-type - #:make-tag - #:tag-name - #:tag-p - #:tag-var - #:tag-ref - ;; environment - #:*global-funs* ; in cmpglobals - #:*cmp-env* #:cmp-env-root #:cmp-env-copy #:cmp-env-mark - #:cmp-env-search-macro - #:cmp-env-search-block - #:cmp-env-register-function - #:cmp-env-register-global-macro - #:cmp-env-register-symbol-macro - #:cmp-env-search-symbol-macro - #:cmp-env-register-block - #:cmp-env-search-var - #:cmp-env-declare-special - #:cmp-env-new-variables - #:cmp-env-register-tag - #:cmp-env-search-tag - #:get-return-type - #:inline-possible ; queries for notinline decl - #:declared-inline-p - #:function-may-change-sp - #:function-may-have-side-effects - #:special-variable-p - #:push-vars - #:add-one-declaration - #:check-arguments-type - #:variable-type-in-env - #:alien-declaration-p - #:get-local-return-type - #:get-local-arg-types - #:policy-check-arguments-type #:policy-type-assertions #:policy-evaluate-forms - #:policy-declaration-name-p #:policy-debug-ihs-frame - ;; first pass interface - #:t1expr #:c1expr #:c1args* #:cmp-eval)) - - (defpackage ecl-cmp/pass1 - (:use #:ffi #:ext #:cl #:c #:ecl-cmp/int)) - - (defpackage "C" - (:nicknames "COMPILER") - (:use "FFI" "EXT" "CL" #:ecl-cmp/int) - (:shadow #:disassemble - #:compile - #:compile-file - #:compile-file-pathname - ;;; These functions will be common in our frontend - ;; #:proclaim #:declaim #:with-compilation-unit - ) - (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" - "*COMPILER-FEATURES*" - "*CC*" - "*CC-OPTIMIZE*" - "*USER-CC-FLAGS*" - "*USER-LD-FLAGS*" - "*SUPPRESS-COMPILER-MESSAGES*" - "BUILD-ECL" - "BUILD-PROGRAM" - "BUILD-FASL" - "BUILD-STATIC-LIBRARY" - "BUILD-SHARED-LIBRARY" - "COMPILER-WARNING" - "COMPILER-NOTE" - "COMPILER-MESSAGE" - "COMPILER-ERROR" - "COMPILER-FATAL-ERROR" - "COMPILER-INTERNAL-ERROR" - "COMPILER-UNDEFINED-VARIABLE" - "COMPILER-MESSAGE-FILE" - "COMPILER-MESSAGE-FILE-POSITION" - "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-MESSAGES*" - "INSTALL-C-COMPILER" - "UPDATE-COMPILER-FEATURES") - (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" - "*COMPILER-CONSTANTS*" "COMPILER-LET")) -#+END_SRC -** TODO be explicit in dispatch symbol packages (i.e cl:progn) -** TODO 'UNWIND-PROTECT tag should be made a keyword -** TODO use package agnostic marks '(CB LB CLB CCB UNWIND-PROTECT CLOSURE) -** TODO declared-inline-p, inline-possible and declared-notinline-p should have one common interface -** cmpdata should be merged with cmpwt (which has only data accessors) -** TODO wt-structure-ref doesn't exist! -This is a removal from CLOS merge probably, fixme! - -** TODO some compiler macros belong to the backend! - -** generic function potential optimizations -*** ecl has one dispatcher and one cache for *all* generic functions - many misses -*** each generic function needs to have its own cache and dispatcher (for instance if there is one method it may be way faster) -*** effective method may be compiled into one function unless one of the methods is a closure (or has eql specializer) - -** Lambdas -#+BEGIN_SRC lisp -;;; lambda expression - -;;; During Pass1, a lambda-list -;;; -;;; ( { var }* -;;; [ &optional { var | ( var [ initform [ svar ] ] ) }* ] -;;; [ &rest var ] -;;; [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}* -;;; [&allow-other-keys]] -;;; [ &aux {var | (var [initform])}*] -;;; ) -;;; -;;; is transformed into -;;; -;;; ( ( { var }* ) ; required -;;; ( { var initform svar }* ) ; optional -;;; { var | nil } ; rest -;;; allow-other-keys-flag -;;; ( { kwd-vv-index var initform svar }* ) ; key -;;; ) -;;; -;;; where -;;; svar: NIL ; means svar is not supplied -;;; | var -;;; -;;; &aux parameters will be embedded into LET*. -;;; -;;; c1lambda-expr receives -;;; ( lambda-list { doc | decl }* . body ) -;;; and returns -;;; ( lambda info-object lambda-list' doc body' ) -;;; -;;; Doc is NIL if no doc string is supplied. -;;; Body' is body possibly surrounded by a LET* (if &aux parameters are -;;; supplied) and an implicit block. -#+END_SRC - -** cmp-env- interface - -*** cmppolicy.lsp:cmp-env-policy :local: -*** cmppolicy.lsp:cmp-env-add-optimizations :internal: -*** cmppolicy.lsp:cmp-env-optimization :external: -*** cmppolicy.lsp:add-default-optimizations :internal: - -*** cmpenv-api.lsp:cmp-env-root :external: -*** cmpenv-api.lsp:cmp-env-copy :external: -*** cmpenv-api.lsp:cmp-env-cleanups :unused: -*** cmpenv-api.lsp:cmp-env-register-var :used: -*** cmpenv-api.lsp:cmp-env-declare-special :used: -*** cmpenv-api.lsp:cmp-env-add-declaration :internal: -*** cmpenv-api.lsp:cmp-env-extend-declaration :internal: - -*** cmpenv-api.lsp:cmp-env-register-function :used: -*** cmpenv-api.lsp:cmp-env-register-global-macro :used: -*** cmpenv-api.lsp:cmp-env-register-macro :used: -*** cmpenv-api.lsp:cmp-env-register-ftype :internal: -*** cmpenv-api.lsp:cmp-env-register-symbol-macro :external: -*** cmpenv-api.lsp:cmp-env-register-block :used: -*** cmpenv-api.lsp:cmp-env-register-tag :used: -*** cmpenv-api.lsp:cmp-env-register-cleanup :unused: - -*** cmpenv-api.lsp:cmp-env-search-function :external: -*** cmpenv-api.lsp:cmp-env-search-variables :local: -*** cmpenv-api.lsp:cmp-env-search-block :used: -*** cmpenv-api.lsp:cmp-env-search-tag :used: -*** cmpenv-api.lsp:cmp-env-search-symbol-macro :external: -*** cmpenv-api.lsp:cmp-env-search-var :external: -*** cmpenv-api.lsp:cmp-env-search-macro :used: -*** cmpenv-api.lsp:cmp-env-search-ftype :internal: - -*** cmpenv-api.lsp:cmp-env-mark :external: -*** cmpenv-api.lsp:cmp-env-new-variables :used: -*** cmpenv-api.lsp:cmp-env-search-declaration :internal: - -** cmpenv-fun.lsp -*** proclaim-function :external: -*** add-function-declaration :internal: -*** get-arg-types :external: -*** get-return-type :external: -*** get-local-arg-types :used: -*** get-local-return-type :used: -*** get-proclaimed-narg :external: -*** declare-inline :internal: -*** declare-notinline :internal: -*** proclaim-inline :internal: -*** proclaim-notinline :internal: -*** declared-inline-p :external: -*** declared-notinline-p :local: -*** inline-possible :external: -*** maybe-install-inline-function :hook: - -** cmpform -*** c1form-local-type :info:unused: -*** c1form-local-vars :info: -*** c1form-sp-change :info: -*** c1form-volatile :info: - -*** c1form-name -*** c1form-parents :local: -*** c1form-env -*** c1form-args -*** c1form-side-effects -*** c1form-form -*** c1form-toplevel-form -*** c1form-file -*** c1form-file-position - -*** print-c1form -*** make-c1form -*** make-c1form* -*** c1form-arg -*** c1form-volatile* :backend: -*** c1form-primary-type -*** location-primary-type (same as above) - -*** find-form-in-node-list -*** add-form-to-node-list -*** delete-form-from-node-list -used only in cmpvar -*** traverse-c1form-tree -*** c1form-movable-p -*** c1form-values-number -*** c1form-single-valued-p -*** with-c1form-env -*** relocate-parents-list :local: -*** c1form-replace-with -*** delete-c1forms -*** c1form-constant-p -