mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-02-14 19:30:57 -08:00
cmp: separate cmpbackend from cmpmain (2)
Introduce compiler-pass/assemble-cxx.
This commit is contained in:
Daniel Kochmański
parent
3f3c89ddb2
commit
244f4e0485
2 changed files with 54 additions and 73 deletions
|
|
@ -530,8 +530,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
|
|||
|
||||
;;; Code generation
|
||||
|
||||
(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name
|
||||
&key input-designator)
|
||||
(defun compiler-pass/generate-cxx (c-pathname h-pathname data-pathname init-name source)
|
||||
|
||||
(setq *compiler-phase* 't2)
|
||||
(with-open-file (*compiler-output1* c-pathname :direction :output
|
||||
|
|
@ -544,7 +543,7 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
|
|||
(declare (ignore second))
|
||||
(wt-comment-nl "Date: ~D/~D/~D ~2,'0D:~2,'0D (yyyy/mm/dd)" year month day hour minute)
|
||||
(wt-comment-nl "Machine: ~A ~A ~A" (software-type) (software-version) (machine-type)))
|
||||
(wt-comment-nl "Source: ~A" input-designator)
|
||||
(wt-comment-nl "Source: ~A" source)
|
||||
(with-open-file (*compiler-output2* h-pathname :direction :output
|
||||
:if-does-not-exist :create
|
||||
:if-exists :supersede)
|
||||
|
|
@ -554,6 +553,32 @@ WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, int nCmdS
|
|||
(terpri *compiler-output2*)))
|
||||
(data-c-dump data-pathname))
|
||||
|
||||
(defun compiler-pass/assemble-cxx (input-file output-file
|
||||
&key
|
||||
(c-file nil)
|
||||
(h-file nil)
|
||||
(data-file nil)
|
||||
(system-p nil)
|
||||
&allow-other-keys)
|
||||
(let* ((cpath (compile-file-pathname output-file :output-file c-file :type :c))
|
||||
(hpath (compile-file-pathname output-file :output-file h-file :type :h))
|
||||
(dpath (compile-file-pathname output-file :output-file data-file :type :data))
|
||||
(opath (compile-file-pathname output-file :type :object))
|
||||
(to-delete (nconc (unless c-file (list cpath))
|
||||
(unless h-file (list hpath))
|
||||
(unless data-file (list dpath))
|
||||
(unless system-p (list opath))))
|
||||
(init-name (compute-init-name output-file :kind (if system-p :object :fasl))))
|
||||
(compiler-pass/generate-cxx cpath hpath dpath init-name input-file)
|
||||
(if system-p
|
||||
(compiler-cc cpath opath)
|
||||
(progn
|
||||
(compiler-cc cpath opath)
|
||||
(bundle-cc (brief-namestring output-file)
|
||||
init-name
|
||||
(list (brief-namestring opath)))))
|
||||
(mapc 'cmp-delete-file to-delete)))
|
||||
|
||||
|
||||
;;; The builder.
|
||||
|
||||
|
|
|
|||
|
|
@ -20,12 +20,11 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defun compile-file-pathname (name &key (output-file T) (type nil type-supplied-p)
|
||||
verbose print c-file h-file data-file
|
||||
system-p load external-format source-truename
|
||||
source-offset)
|
||||
(declare (ignore verbose print c-file h-file data-file load
|
||||
external-format source-truename source-offset))
|
||||
(defun compile-file-pathname (name &key
|
||||
(output-file T)
|
||||
(type nil type-supplied-p)
|
||||
(system-p nil)
|
||||
&allow-other-keys)
|
||||
(let* ((format '())
|
||||
(extension '()))
|
||||
(unless type-supplied-p
|
||||
|
|
@ -76,14 +75,15 @@
|
|||
(ext:*source-location* (cons source-truename 0))
|
||||
(*suppress-compiler-messages* (or *suppress-compiler-messages*
|
||||
(not *compile-verbose*))))
|
||||
(declare (notinline compiler-cc))
|
||||
(declare (notinline compiler-cc)
|
||||
(ignorable c-file h-file data-file))
|
||||
"Compiles the file specified by INPUT-PATHNAME and generates a fasl file
|
||||
specified by OUTPUT-FILE. If the filetype is not specified in INPUT-PATHNAME,
|
||||
then \".lsp\" is used as the default file type for the source file. LOAD
|
||||
specifies whether to load the generated fasl file after compilation. The
|
||||
:O-FILE, :C-FILE, :H-FILE, and :DATA-FILE keyword parameters allow you to
|
||||
control the intermediate files generated by the ECL compiler.If the file was
|
||||
compiled successfully, returns the pathname of the compiled file"
|
||||
compiled successfully, returns the pathname of the compiled file."
|
||||
#-dlopen
|
||||
(unless system-p
|
||||
(format t "~%;;;~
|
||||
|
|
@ -105,47 +105,23 @@ compiled successfully, returns the pathname of the compiled file"
|
|||
(let* ((input-file (truename *compile-file-pathname*))
|
||||
(*compile-file-truename* input-file)
|
||||
(*compiler-in-use* *compiler-in-use*)
|
||||
(*load-time-values* nil) ;; Load time values are compiled
|
||||
(output-file (apply #'compile-file-pathname input-file
|
||||
:output-file output-file args))
|
||||
(true-output-file nil) ;; Will be set at the end
|
||||
(c-pathname (apply #'compile-file-pathname output-file :output-file c-file
|
||||
:type :c args))
|
||||
(h-pathname (apply #'compile-file-pathname output-file :output-file h-file
|
||||
:type :h args))
|
||||
(data-pathname (apply #'compile-file-pathname output-file
|
||||
:output-file data-file :type :data args))
|
||||
(compiler-conditions nil)
|
||||
(to-delete (nconc (unless c-file (list c-pathname))
|
||||
(unless h-file (list h-pathname))
|
||||
(unless data-file (list data-pathname))))
|
||||
(init-name (compute-init-name output-file
|
||||
:kind (if system-p :object :fasl))))
|
||||
(*load-time-values* nil) ; Load time values are compiled.
|
||||
(output-file (apply #'compile-file-pathname input-file :output-file output-file args))
|
||||
(true-output-file nil) ; Will be set at the end.
|
||||
(compiler-conditions nil))
|
||||
(with-compiler-env (compiler-conditions)
|
||||
(print-compiler-info)
|
||||
(when (probe-file "./cmpinit.lsp")
|
||||
(load "./cmpinit.lsp" :verbose *compile-verbose*))
|
||||
(with-open-file (stream *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*))
|
||||
(compiler-pass1 stream source-offset))
|
||||
(compiler-pass/propagate-types)
|
||||
(compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name
|
||||
:input-designator (namestring input-pathname))
|
||||
(if system-p
|
||||
(compiler-cc c-pathname output-file)
|
||||
(let ((o-pathname (compile-file-pathname output-file :type :object)))
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
(push o-pathname to-delete)
|
||||
(bundle-cc (brief-namestring output-file)
|
||||
init-name
|
||||
(list (brief-namestring o-pathname)))))
|
||||
(apply #'compiler-pass/assemble-cxx input-file output-file args)
|
||||
(if (setf true-output-file (probe-file output-file))
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%;;;~%"
|
||||
(namestring input-pathname))
|
||||
(cmpprogress "~&;;; Finished compiling ~a.~%;;;~%" (namestring input-pathname))
|
||||
(cmperr "The C compiler failed to compile the intermediate file."))
|
||||
(mapc #'cmp-delete-file to-delete)
|
||||
(when load
|
||||
(load true-output-file :verbose *compile-verbose*))) ; with-compiler-env
|
||||
(compiler-output-values true-output-file compiler-conditions)))
|
||||
|
|
@ -224,12 +200,7 @@ after compilation."
|
|||
|
||||
(let* ((*load-time-values* 'values) ;; Only the value is kept
|
||||
(tmp-names (safe-mkstemp (format nil "TMP:ECL~3,'0x" (incf *gazonk-counter*))))
|
||||
(data-pathname (first tmp-names))
|
||||
(c-pathname (compile-file-pathname data-pathname :type :c))
|
||||
(h-pathname (compile-file-pathname data-pathname :type :h))
|
||||
(o-pathname (compile-file-pathname data-pathname :type :object))
|
||||
(so-pathname (compile-file-pathname data-pathname))
|
||||
(init-name (compute-init-name so-pathname :kind :fasl))
|
||||
(so-pathname (compile-file-pathname (first tmp-names)))
|
||||
(compiler-conditions nil)
|
||||
(*permanent-data* t) ; needed for literal objects in closures
|
||||
(*cmp-env-root* *cmp-env-root*))
|
||||
|
|
@ -239,18 +210,7 @@ after compilation."
|
|||
(compiler-pass1 form)
|
||||
(compiler-pass/propagate-types)
|
||||
(let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
|
||||
(compiler-pass/generate-cxx c-pathname h-pathname data-pathname init-name
|
||||
:input-designator (let* ((*print-circle* t)
|
||||
(*print-length* 8)
|
||||
(*print-depth* 4))
|
||||
(format nil "~W" def))))
|
||||
(compiler-cc c-pathname o-pathname)
|
||||
(bundle-cc (brief-namestring so-pathname)
|
||||
init-name
|
||||
(list (brief-namestring o-pathname)))
|
||||
(cmp-delete-file c-pathname)
|
||||
(cmp-delete-file h-pathname)
|
||||
(cmp-delete-file o-pathname)
|
||||
(compiler-pass/assemble-cxx nil so-pathname))
|
||||
(mapc 'cmp-delete-file tmp-names)
|
||||
(cond ((probe-file so-pathname)
|
||||
(load so-pathname :verbose nil)
|
||||
|
|
@ -260,10 +220,6 @@ after compilation."
|
|||
(set 'GAZONK nil)
|
||||
(cmperr "The C compiler failed to compile the intermediate code for ~s." name)))
|
||||
) ; with-compiler-env
|
||||
(cmp-delete-file c-pathname)
|
||||
(cmp-delete-file h-pathname)
|
||||
(cmp-delete-file so-pathname)
|
||||
(mapc 'cmp-delete-file tmp-names)
|
||||
(let ((output (or name (and (boundp 'GAZONK) (symbol-value 'GAZONK))
|
||||
#'(lambda (&rest x)
|
||||
(declare (ignore x))
|
||||
|
|
@ -293,24 +249,24 @@ disassembled. If THING is a lambda expression, it is disassembled as a
|
|||
function definition. Otherwise, THING itself is disassembled as a top-level
|
||||
form. H-FILE and DATA-FILE specify intermediate files to build a fasl file
|
||||
from the C language code. NIL means \"do not create the file\"."
|
||||
(when (si::valid-function-name-p thing)
|
||||
(when (si:valid-function-name-p thing)
|
||||
(setq thing (fdefinition thing)))
|
||||
(when (and (functionp thing) (function-lambda-expression thing))
|
||||
(multiple-value-setq (thing lexenv)
|
||||
(function-lambda-expression thing))
|
||||
(when (eq lexenv t)
|
||||
(warn "DISASSEMBLE can not disassemble C closures")
|
||||
(warn "DISASSEMBLE can not disassemble C closures.")
|
||||
(return-from disassemble nil)))
|
||||
(cond ((null thing))
|
||||
((functionp thing)
|
||||
(unless (si::bc-disassemble thing)
|
||||
(unless (si:bc-disassemble thing)
|
||||
(warn "Cannot disassemble the binary function ~S because I do not have its source code." thing)
|
||||
(return-from disassemble nil)))
|
||||
((atom thing)
|
||||
(error 'simple-type-error
|
||||
:datum thing
|
||||
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
|
||||
:format-control "DISASSEMBLE cannot accept ~A"
|
||||
:format-control "DISASSEMBLE cannot accept ~A."
|
||||
:format-arguments (list thing)))
|
||||
((eq (car thing) 'LAMBDA)
|
||||
(setq disassembled-form `(defun gazonk ,@(cdr thing))))
|
||||
|
|
@ -320,7 +276,7 @@ from the C language code. NIL means \"do not create the file\"."
|
|||
(error 'simple-type-error
|
||||
:datum thing
|
||||
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
|
||||
:format-control "DISASSEMBLE cannot accept ~A"
|
||||
:format-control "DISASSEMBLE cannot accept ~A."
|
||||
:format-arguments (list thing))))
|
||||
|
||||
(let* ((null-stream (make-broadcast-stream))
|
||||
|
|
@ -358,8 +314,8 @@ from the C language code. NIL means \"do not create the file\"."
|
|||
(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)))
|
||||
(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*)
|
||||
|
|
@ -395,12 +351,12 @@ from the C language code. NIL means \"do not create the file\"."
|
|||
(compile-file #'compile-file)
|
||||
(compile-file-pathname #'compile-file-pathname))
|
||||
(defun ext:install-c-compiler ()
|
||||
(ext::package-lock (find-package :cl) nil)
|
||||
(ext:package-lock (find-package :cl) nil)
|
||||
(setf *features* (delete :ecl-bytecmp *features*))
|
||||
(setf (fdefinition 'disassemble) disassemble
|
||||
(fdefinition 'compile) compile
|
||||
(fdefinition 'compile-file) compile-file
|
||||
(fdefinition 'compile-file-pathname) compile-file-pathname)
|
||||
(ext::package-lock (find-package :cl) t)))
|
||||
(ext:package-lock (find-package :cl) t)))
|
||||
|
||||
(provide 'cmp)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue