mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-11 03:33:11 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/cmp/cmpmain.lsp
jjgarcia 01cfc8dc8f Reactivate deletion of temporary files.
2003-11-06 08:35:37 +00:00

644 lines
21 KiB
Common Lisp
Raw Blame History

;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPMAIN Compiler main program.
;;; **** Caution ****
;;; This file is machine/OS dependant.
;;; *****************
(in-package "COMPILER")
(defvar *cmpinclude* "<ecl-cmp.h>")
;;; This is copied into each .h file generated, EXCEPT for system-p calls.
;;; The constant string *include-string* is the content of file "ecl.h".
;;; Here we use just a placeholder: it will be replaced with sed.
(defvar *cc* "cc"
"This variable controls how the C compiler is invoked by ECL.
The default value is \"cc -I. -I/usr/local/include/\".
The second -I option names the directory where the file ECL.h has been installed.
One can set the variable appropriately adding for instance flags which the
C compiler may need to exploit special hardware features (e.g. a floating point
coprocessor).")
(defvar *cc-flags* "-g -I.")
(defvar *cc-optimize* "-O") ; C compiler otimization flag
(defvar *cc-format* "~A ~A ~:[~*~;~A~] -I~A/h -w -c ~A -o ~A"))
;(defvar *cc-format* "~A ~A ~:[~*~;~A~] -I~A/h -c ~A -o ~A"))
(defvar *ld-flags* "")
(defvar *ld-format* "~A ~A -w -o ~A -L~A ~{~A ~} ~@?")
#+dlopen
(defvar *ld-shared-flags* "")
#+dlopen
(defvar *ld-shared-format* "~A ~A -o ~A -L~A ~{~A ~} ~@?")
(defun safe-system (string)
(print string)
(let ((result (si:system string)))
(unless (zerop result)
(cerror "Continues anyway."
"(SYSTEM ~S) returned non-zero value ~D"
string result))
result))
(defun compile-file-pathname (name &key (output-file name) (type :fasl))
(let ((format '())
(extension '()))
(case type
((:shared-library :dll) (setf format #.+shared-library-format+))
((:static-library :library :lib) (setf format #.+static-library-format+))
(:data (setf extension "data"))
(:sdata (setf extension "sdat"))
(:c (setf extension "c"))
(:h (setf extension "h"))
(:object (setf extension #.+object-file-extension+))
(:program (setf format #.+executable-file-format+))
(:fasl (setf extension "fas")))
(if format
(merge-pathnames (format nil format (pathname-name output-file))
output-file)
(make-pathname :type extension :defaults output-file))))
(defun linker-cc (o-pathname &rest options)
(safe-system
(format nil
*ld-format*
*cc*
""
(namestring o-pathname)
(namestring (translate-logical-pathname "SYS:"))
options
*ld-flags* (namestring (translate-logical-pathname "SYS:")))))
#+dlopen
(defun shared-cc (o-pathname &rest options)
(safe-system
(format nil
*ld-shared-format*
*cc*
*ld-shared-flags*
(namestring o-pathname)
(namestring (translate-logical-pathname "SYS:"))
options
*ld-flags* (namestring (translate-logical-pathname "SYS:")))))
(defconstant +lisp-program-header+ "
#include <ecl.h>
#ifdef __cplusplus
#define ECL_CPP_TAG \"C\"
#else
#define ECL_CPP_TAG
#endif
~{ extern ECL_CPP_TAG void init_~A();~%~}
")
(defconstant +lisp-program-init+ "
#ifdef __cplusplus
extern \"C\"
#endif
int init_~A(cl_object cblock)
{
static cl_object Cblock;
cl_object subblock;
if (!FIXNUMP(cblock)) {
Cblock = cblock;
cblock->cblock.data_text = compiler_data_text;
cblock->cblock.data_text_size = compiler_data_text_size;
#ifndef ECL_DYNAMIC_VV
cblock->cblock.data = VV;
#endif
cblock->cblock.data_size = VM;
return;
}
#if defined(ECL_DYNAMIC_VV) && defined(ECL_SHARED_DATA)
VV = Cblock->cblock.data;
#endif
~A
~:[~{ subblock = read_VV(OBJNULL,init_~A); subblock->cblock.next = Cblock;~%~}
~;~{ init_~A(Cblock);~%~}~]
~A
}")
(defconstant +lisp-program-main+ "
int
main(int argc, char **argv)
{
~A
cl_boot(argc, argv);
read_VV(OBJNULL, init_~A);
~A
}")
(defun init-function-name (s)
(flet ((translate-char (c)
(cond ((and (char>= c #\a) (char<= c #\z))
(char-upcase c))
((and (char>= c #\A) (char<= c #\Z))
c)
((or (eq c #\-) (eq c #\_))
#\_)
((eq c #\*)
#\x)
((eq c #\?)
#\a)
(t
#\p))))
(setq s (map 'string #'translate-char (string s)))
(if si::*init-function-prefix*
(concatenate 'string si::*init-function-prefix* "_" s)
s)))
(defun builder (target output-name &key lisp-files ld-flags shared-data-file
(prologue-code "")
(epilogue-code (if (eq target :program) "
funcall(1,_intern(\"TOP-LEVEL\",system_package));
return 0;" "")))
(let* ((c-name (namestring (compile-file-pathname output-name :type :c)))
(o-name (namestring (compile-file-pathname output-name :type :object)))
(init-name (string-upcase (pathname-name c-name)))
submodules
c-file)
(dolist (item (reverse lisp-files))
(cond ((symbolp item)
(push (format nil "-l~A" (string-downcase item)) ld-flags)
(push (init-function-name item) submodules))
(t
(push (namestring (compile-file-pathname item :type :object)) ld-flags)
(setq item (pathname-name item))
(push (init-function-name item) submodules))))
(setq c-file (open c-name :direction :output))
(format c-file +lisp-program-header+ submodules)
(cond (shared-data-file
(data-init shared-data-file)
(format c-file "
#define VM ~A
#ifdef ECL_DYNAMIC_VV
cl_object *VV;
#else
cl_object VV[VM];
#endif
cl_object Cblock;
#define ECL_SHARED_DATA_FILE 1
" (data-size))
(data-dump c-file))
(t
(format c-file "
#define compiler_data_text NULL
#define compiler_data_text_size 0
#define VV NULL
#define VM 0" c-file)))
(ecase target
(:program
(when (or (symbolp output-name) (stringp output-name))
(setf output-name (compile-file-pathname output-name :type :program)))
(format c-file +lisp-program-init+ init-name "" shared-data-file
submodules "")
(format c-file +lisp-program-main+ prologue-code init-name epilogue-code)
(close c-file)
(si:system (format nil "cat ~A" (namestring c-name)))
(compiler-cc c-name o-name)
(apply #'linker-cc output-name (namestring o-name) ld-flags))
((:library :static-library :lib)
(if (or (symbolp output-name) (stringp output-name))
(setf output-name (compile-file-pathname output-name :type :lib))
;; Remove the leading "lib"
(setf init-name (subseq init-name #.(length +static-library-prefix+))))
(format c-file +lisp-program-init+ init-name prologue-code
shared-data-file submodules epilogue-code)
(close c-file)
(si:system (format nil "cat ~A" (namestring c-name)))
(compiler-cc c-name o-name)
(safe-system (format nil "ar cr ~A ~A ~{~A ~}"
output-name o-name ld-flags))
(safe-system (format nil "ranlib ~A" output-name)))
#+dlopen
((:shared-library :dll)
(if (or (symbolp output-name) (stringp output-name))
(setf output-name (compile-file-pathname output-name :type :dll))
;; Remove the leading "lib"
(setf init-name (subseq init-name #.(length +static-library-prefix+))))
(format c-file +lisp-program-init+ init-name prologue-code
shared-data-file submodules epilogue-code)
(close c-file)
(si:system (format nil "cat ~A" (namestring c-name)))
(compiler-cc c-name o-name)
(apply #'shared-cc output-name o-name ld-flags))
(:fasl
(when (or (symbolp output-name) (stringp output-name))
(setf output-name (compile-file-pathname output-name :type :fasl)))
(format c-file +lisp-program-init+ "CODE" prologue-code
shared-data-file submodules epilogue-code)
(close c-file)
(si:system (format nil "cat ~A" (namestring c-name)))
(compiler-cc c-name o-name)
(apply #'shared-cc output-name o-name ld-flags)))
(delete-file c-name)
(delete-file o-name)
output-name))
(defun build-fasl (&rest args)
(apply #'builder :fasl args))
(defun build-program (&rest args)
(apply #'builder :program args))
(defun build-static-library (&rest args)
(apply #'builder :static-library args))
(defun build-shared-library (&rest args)
#-dlopen
(error "Dynamically loadable libraries not supported in this system.")
#+dlopen
(apply #'builder :shared-library args))
(eval-when (compile eval)
(defmacro get-output-pathname (input-file output-file ext)
`(compile-file-pathname ,input-file
:output-file (if (member ,output-file '(T NIL)) ,input-file ,output-file)
:type ,ext)))
(defun compile-file (input-pathname
&key (output-file 'T)
(verbose *compile-verbose*)
(print *compile-print*)
(c-file nil)
(h-file nil)
(data-file nil)
(shared-data-file nil)
(system-p nil)
(load nil)
&aux (*standard-output* *standard-output*)
(*error-output* *error-output*)
(*compiler-in-use* *compiler-in-use*)
(*package* *package*)
(*print-pretty* nil)
(*error-count* 0)
(*compile-file-pathname* nil)
(*compile-file-truename* nil)
#+PDE sys:*source-pathname*)
(declare (notinline compiler-cc))
#-dlopen
(unless system-p
(format t "~%;;;~
~%;;; This system does not support loading dynamically linked libraries.~
~%;;; Therefore, COMPILE-FILE without :SYSTEM-P T is unsupported.~
~%;;;"))
(setq *compile-file-pathname* (make-pathname :type "lsp" :defaults input-pathname))
(unless (probe-file *compile-file-pathname*)
(setq *compile-file-pathname* (make-pathname :type "lisp" :defaults input-pathname))
(unless (probe-file *compile-file-pathname*)
(format t "~&;;; The source file ~a is not found.~%"
(namestring input-pathname))
(setq *error-p* t)
(return-from compile-file (values nil t t))))
(setq *compile-file-truename* (truename *compile-file-pathname*))
#+PDE (setq sys:*source-pathname* *compile-file-truename*)
(when (and system-p load)
(error "Cannot load system files."))
(when *compiler-in-use*
(format t "~&;;; The compiler was called recursively.~%~
Cannot compile ~a."
(namestring input-pathname))
(setq *error-p* t)
(return-from compile-file (values nil t t)))
(setq *error-p* nil
*compiler-in-use* t)
(when *compile-verbose*
(format t "~&;;; Compiling ~a."
(namestring input-pathname)))
(let* ((eof '(NIL))
(*load-time-values* nil) ;; Load time values are compiled
(o-pathname (get-output-pathname input-pathname output-file :object))
#+dlopen
(so-pathname (unless system-p (compile-file-pathname o-pathname)))
(c-pathname (get-output-pathname o-pathname c-file :c))
(h-pathname (get-output-pathname o-pathname h-file :h))
(data-pathname (get-output-pathname o-pathname data-file :data))
(shared-data-pathname (get-output-pathname o-pathname shared-data-file
:sdata)))
(init-env)
(when (probe-file "./cmpinit.lsp")
(load "./cmpinit.lsp" :verbose *compile-verbose*))
(if shared-data-file
(if system-p
(data-init shared-data-pathname)
(error "Shared data files are only allowed when compiling ~&
with the flag :SYSTEM-P set to T."))
(data-init))
(with-open-file (*compiler-input* *compile-file-pathname*)
(do ((form (read *compiler-input* nil eof)
(read *compiler-input* nil eof)))
((eq form eof))
(t1expr form)))
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname system-p
(if system-p
(pathname-name input-pathname)
"code")
shared-data-file))
(if shared-data-file
(data-dump shared-data-pathname t)
(data-dump data-pathname))
(init-env)
(if (zerop *error-count*)
(progn
(cond (output-file
(when *compile-verbose*
(format t "~&;;; Calling the C compiler... "))
(compiler-cc c-pathname o-pathname)
#+dlopen
(unless system-p (shared-cc so-pathname o-pathname))
(cond #+dlopen
((and (not system-p) (probe-file so-pathname))
(when load (load so-pathname))
(when *compile-verbose*
(print-compiler-info)
(format t "~&;;; Finished compiling ~a."
(namestring input-pathname))))
((and system-p (probe-file o-pathname))
(when *compile-verbose*
(print-compiler-info)
(format t "~&;;; Finished compiling ~a."
(namestring input-pathname))))
(t (format t "~&;;; The C compiler failed to compile the intermediate file.~%")
(setq *error-p* t))))
(*compile-verbose*
(print-compiler-info)
(format t "~&;;; Finished compiling ~a."
(namestring input-pathname))))
(unless c-file (delete-file c-pathname))
(unless h-file (delete-file h-pathname))
(unless (or data-file shared-data-file)
(delete-file data-pathname))
#+dlopen
(unless system-p (delete-file o-pathname))
#+dlopen
(if system-p o-pathname so-pathname)
#-dlopen
(values o-pathname nil nil))
(progn
(when (probe-file c-pathname) (delete-file c-pathname))
(when (probe-file h-pathname) (delete-file h-pathname))
(when (probe-file data-pathname) (delete-file data-pathname))
(when (probe-file shared-data-pathname) (delete-file shared-data-pathname))
(when (probe-file o-pathname) (delete-file o-pathname))
(format t "~&;;; Due to errors in the compilation process, no FASL was generated.
;;; Search above for the \"Error:\" tag to find the error messages.~%")
(setq *error-p* t)
(values nil t t))
))
)
#-dlopen
(defun compile (name &optional (def nil supplied-p))
(format t "~%;;;~
~%;;; This system does not support loading dynamically linked libraries.~
~%;;; Therefore, COMPILE is unsupported.~
~%;;;"))
#+dlopen
(defvar *gazonk-counter* 0)
#+dlopen
(defun compile (name &optional (def nil supplied-p)
&aux form data-pathname
(*compiler-in-use* *compiler-in-use*)
(*standard-output* *standard-output*)
(*error-output* *error-output*)
(*package* *package*)
(*compile-print* nil)
(*print-pretty* nil)
(*error-count* 0))
(unless (symbolp name) (error "~s is not a symbol." name))
(when *compiler-in-use*
(format t "~&;;; The compiler was called recursively.~
~%Cannot compile ~s." name)
(setq *error-p* t)
(return-from compile (values name nil t)))
(setq *error-p* nil
*compiler-in-use* t)
(cond ((and supplied-p def)
(setq form (if name
`(setf (symbol-function ',name) #',def)
`(set 'GAZONK #',def))))
((and (fboundp name)
(setq def (symbol-function name))
(setq form (function-lambda-expression def)))
(setq form `(setf (symbol-function ',name) #',form)))
(t (error "No lambda expression is assigned to the symbol ~s." name)))
(let ((template (format nil "~A/ecl~3,'0x"
(or (si::getenv "TMPDIR") "/tmp")
(incf *gazonk-counter*))))
(unless (setq data-pathname (pathname (si::mkstemp template)))
(format t "~&;;; Unable to create temporay file~%~
;;; ~AXXXXXX
;;; Make sure you have enough free space in disk, check permissions or set~%~
;;; the environment variable TMPDIR to a different value." template)
(setq *error-p* t)
(return-from compile (values nil t t))))
(let ((*load-time-values* 'values) ;; Only the value is kept
(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-env)
(data-init)
(t1expr form)
(when (zerop *error-count*)
(when *compile-verbose* (format t "~&;;; End of Pass 1. "))
(compiler-pass2 c-pathname h-pathname data-pathname nil "code" nil))
(data-dump data-pathname)
(init-env)
(if (zerop *error-count*)
(progn
(when *compile-verbose*
(format t "~&;;; Calling the C compiler... "))
;;(si::system (format nil "cat ~A" (namestring c-pathname)))
(compiler-cc c-pathname o-pathname)
(shared-cc so-pathname o-pathname)
(delete-file c-pathname)
(delete-file h-pathname)
(delete-file o-pathname)
(cond ((probe-file so-pathname)
(load so-pathname :verbose nil)
(when *compile-verbose* (print-compiler-info))
(delete-file so-pathname)
(delete-file data-pathname)
(setf name (or name (symbol-value 'GAZONK)))
;; By unsetting GAZONK we avoid spurious references to the
;; loaded code.
(set 'GAZONK nil)
(si::gc t)
(values name nil nil))
(t (delete-file data-pathname)
(format t "~&;;; The C compiler failed to compile~
~the intermediate code for ~s.~%" name)
(setq *error-p* t)
(values name t t))))
(progn
(when (probe-file c-pathname) (delete-file c-pathname))
(when (probe-file h-pathname) (delete-file h-pathname))
(when (probe-file so-pathname) (delete-file so-pathname))
(when (probe-file data-pathname) (delete-file data-pathname))
(format t "~&;;; Failed to compile ~s.~%" name)
(setq *error-p* t)
(values name t t)))))
(defun disassemble (&optional (thing nil)
&key (h-file nil) (data-file nil)
&aux def disassembled-form
(*compiler-in-use* *compiler-in-use*)
(*print-pretty* nil))
(when (si::valid-function-name-p thing)
(setq thing (fdefinition thing)))
(cond ((null thing))
((functionp thing)
(unless (si::bc-disassemble thing)
(error "The function definition for ~S was lost." thing)))
((and (consp thing) (eq (car thing) 'LAMBDA))
(setq disassembled-form `(defun gazonk ,@(cdr thing))))
(t (setq disassembled-form thing)))
(when *compiler-in-use*
(format t "~&;;; The compiler was called recursively.~
~%Cannot disassemble ~a." thing)
(setq *error-p* t)
(return-from disassemble))
(setq *error-p* nil
*compiler-in-use* t)
(let* ((null-stream (make-broadcast-stream))
(*compiler-output1* null-stream)
(*compiler-output2* (if h-file
(open h-file :direction :output)
null-stream))
(*error-count* 0)
(t3local-fun (symbol-function 'T3LOCAL-FUN))
(t3fun (get-sysprop 'DEFUN 'T3)))
(unwind-protect
(progn
(put-sysprop 'DEFUN 'T3
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3fun args))))
(setf (symbol-function 'T3LOCAL-FUN)
#'(lambda (&rest args)
(let ((*compiler-output1* *standard-output*))
(apply t3local-fun args))))
(init-env)
(data-init)
(t1expr disassembled-form)
(if (zerop *error-count*)
(catch *cmperr-tag* (ctop-write "code"
(if h-file (namestring h-file) "")
(if data-file (namestring data-file) "")
:system-p nil))
(setq *error-p* t))
(data-dump data-file)
)
(put-sysprop 'DEFUN 'T3 t3fun)
(setf (symbol-function 'T3LOCAL-FUN) t3local-fun)
(when h-file (close *compiler-output2*))))
(values)
)
(defun compiler-pass2 (c-pathname h-pathname data-pathname system-p init-name
shared-data)
(with-open-file (*compiler-output1* c-pathname :direction :output)
(with-open-file (*compiler-output2* h-pathname :direction :output)
(wt-nl1 "#include " *cmpinclude*)
(catch *cmperr-tag* (ctop-write (string-upcase init-name)
(namestring h-pathname)
(namestring data-pathname)
:system-p system-p
:shared-data shared-data))
(terpri *compiler-output1*)
(terpri *compiler-output2*))))
(defun compiler-cc (c-pathname o-pathname)
(safe-system
(format nil
*cc-format*
*cc* *cc-flags* (>= *speed* 2) *cc-optimize*
(namestring (translate-logical-pathname "SYS:"))
(namestring c-pathname)
(namestring o-pathname))
; Since the SUN4 assembler loops with big files, you might want to use this:
; (format nil
; "~A ~@[~*-O1~] -S -I. -I~A -w ~A ; as -o ~A ~A"
; *cc* (>= *speed* 2)
; *include-directory*
; (namestring c-pathname)
; (namestring o-pathname)
; (namestring s-pathname))
))
(defun print-compiler-info ()
(format t "~&;;; OPTIMIZE levels: Safety=~d~:[ (No runtime error checking)~;~], Space=~d, Speed=~d~%"
(cond ((null *compiler-check-args*) 0)
((null *safe-compile*) 1)
((null *compiler-push-events*) 2)
(t 3))
*safe-compile* *space* *speed*))
#+dlopen
(defun load-o-file (file verbose print)
(let ((tmp (compile-file-pathname file)))
(shared-cc tmp file)
(when (probe-file tmp)
(load tmp :verbose nil :print nil)
(delete-file tmp)
nil)))
#+dlopen
(push (cons #.+object-file-extension+ #'load-o-file) si::*load-hooks*)
(defmacro with-compilation-unit (options &rest body)
`(progn ,@body))
;;; ----------------------------------------------------------------------
(provide "compiler")
Reference in a new issue View git blame Copy permalink