mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-13 08:20:31 -07:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'refactor-compiler' into 'develop'

Browse source 
Minor compiler improvements

See merge request embeddable-common-lisp/ecl!170
This commit is contained in:
Marius Gerbershagen 2019-12-16 18:02:36 +00:00
commit a7a18707b8
8 changed files with 900 additions and 625 deletions
Download patch file Download diff file Expand all files Collapse all files

154
src/cmp/cmpc-machine.lsp
View file

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

153
src/cmp/cmpcbk.lsp
View file

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

16
src/cmp/cmpglobals.lsp
View file

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

48
src/cmp/cmpmain.lsp
View file

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

71
src/cmp/cmptop.lsp
View file

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

708
src/cmp/notes.org Normal file
View file

@ -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.
- <file-name>.eclh :: static data, declarations and symbol mappings
#+BEGIN_SRC c (<file-name>.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 <ecl/internal.h>
static int ecl_callback_0(int var0,int var1);
#+END_SRC
- <file-name>.data :: data segment
#+BEGIN_SRC c (<file-name>.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
- <file-name>.c :: function definitions and the initialization code
#+BEGIN_SRC c (<file-name>.c pseudocode)
#include <ecl/ecl-cmp.h>
#include "/absolute/path/to/<file-name>.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/<file-name>.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

6
src/lsp/ffi.lsp
View file

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

369
src/newcmp/notes.org
View file

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