mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 06:42:18 -08:00
b730412ebc
When a literal appears in the file multiple times its identity should be preserved. CLHS 3.2.4.4: > If two literal objects appearing in the source code for a single > file processed with the file compiler are the identical, the > corresponding objects in the compiled code must also be the identical. Previously, every bytecode object created during ext::bc-compile-file had its own vector of constants making it impossible to satisfy this constraint. Thus, we change ext::bc-compile-file to use the same constants vector for all bytecode objects from the same file. The simplest way to achieve this is to use the same compiler environment for all of the compilation process and push the read-compile loop into the si_bc_compile_from_stream function implemented in C.
152 lines
6.7 KiB
Common Lisp
Executable file
152 lines
6.7 KiB
Common Lisp
Executable file
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
|
|
;;;; Copyright (c) 1990, Giuseppe Attardi.
|
|
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll
|
|
;;;;
|
|
;;;; 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.
|
|
|
|
;;;; BYTECMP Fake compiler which is used as a replacement when we do not
|
|
;;;; want or can have the real native compiler.
|
|
|
|
(in-package "EXT")
|
|
|
|
(defpackage "C"
|
|
(:use "CL")
|
|
(:export
|
|
"*SUPPRESS-COMPILER-WARNINGS*"
|
|
"*SUPPRESS-COMPILER-NOTES*"))
|
|
|
|
(defun bc-disassemble (thing)
|
|
(when (si::valid-function-name-p thing)
|
|
(setq thing (fdefinition thing)))
|
|
(cond ((null thing))
|
|
((functionp thing)
|
|
(si::bc-disassemble thing))
|
|
((and (consp thing)
|
|
(member (car thing) '(LAMBDA 'EXT:LAMBDA-BLOCK)))
|
|
(disassemble (compile nil thing)))
|
|
(t
|
|
(error 'simple-type-error
|
|
:datum thing
|
|
:expected-type '(OR FUNCTION (SATISFIES SI:VALID-FUNCTION-NAME-P))
|
|
:format-control "DISASSEMBLE cannot accept ~A."
|
|
:format-arguments (list thing))))
|
|
nil)
|
|
|
|
(defun bc-compile (name &optional (definition nil def-p) &aux (*print-pretty* nil))
|
|
(check-type name (or (satisfies si:valid-function-name-p) nil))
|
|
(when def-p (check-type definition (or function cons)))
|
|
(cond ((functionp definition)
|
|
(multiple-value-bind (form lexenv) (function-lambda-expression definition)
|
|
(when form
|
|
(cond ((eq lexenv t)
|
|
(warn "COMPILE can not compile C closures")
|
|
(return-from bc-compile (values definition t nil)))
|
|
(lexenv (setf definition (si:eval-with-env form lexenv)))
|
|
(t (setf definition (si:eval-with-env form nil nil nil :execute))))))
|
|
(when name (setf (fdefinition name) definition))
|
|
(return-from bc-compile (values (or name definition) nil nil)))
|
|
((not (null definition))
|
|
(unless (member (car definition) '(LAMBDA EXT:LAMBDA-BLOCK))
|
|
(format t "~&;;; Error: Not a valid lambda expression: ~s." definition)
|
|
(return-from bc-compile (values nil t t)))
|
|
(setq definition (si:eval-with-env definition nil nil nil :execute))
|
|
(when name (setf (fdefinition name) definition))
|
|
(return-from bc-compile (values (or name definition) nil nil)))
|
|
((not (fboundp name))
|
|
(error "Function name ~s is unbound." name))
|
|
((typep (fdefinition name) 'standard-generic-function)
|
|
(warn "COMPILE can not compile generic functions yet.")
|
|
(return-from bc-compile (values name t nil)))
|
|
(T
|
|
(multiple-value-bind (form lexenv)
|
|
(function-lambda-expression (fdefinition name))
|
|
(when form
|
|
(cond ((eq lexenv t)
|
|
(warn "The bytecodes compiler can not compile C closures")
|
|
(return-from bc-compile (values definition t nil)))
|
|
(lexenv (setf definition (si:eval-with-env form lexenv)))
|
|
(t (setf definition (si:eval-with-env form nil nil nil :execute))))))
|
|
(when (null definition)
|
|
(warn "We have lost the original function definition for ~s." name)
|
|
(return-from bc-compile (values name t nil)))
|
|
(return-from bc-compile (values name nil nil)))))
|
|
|
|
(defun bc-compile-file-pathname (name &key (output-file name) (type :fasl)
|
|
verbose print c-file h-file data-file
|
|
shared-data-file system-p load external-format)
|
|
(declare (ignore load c-file h-file data-file shared-data-file system-p verbose print external-format))
|
|
(let ((extension "fasc"))
|
|
(case type
|
|
((:fasl :fas) (setf extension "fasc"))
|
|
(t (error "In COMPILE-FILE-PATHNAME, the type ~A is unsupported." type)))
|
|
(make-pathname :type extension :defaults output-file)))
|
|
|
|
(defun bc-compile-file (input
|
|
&key
|
|
((:verbose *compile-verbose*) *compile-verbose*)
|
|
((:print *compile-print*) *compile-print*)
|
|
(load nil)
|
|
(external-format :default)
|
|
(output-file nil output-file-p)
|
|
&allow-other-keys &aux foo)
|
|
(setf output-file (if (and output-file-p (not (eql output-file t)))
|
|
(pathname output-file)
|
|
(bc-compile-file-pathname input)))
|
|
(when *compile-verbose*
|
|
(format t "~&;;; Compiling ~A." input))
|
|
(cond ((not (streamp input))
|
|
(let* ((ext:*source-location* (cons (truename input) 0))
|
|
(*compile-file-pathname* (pathname (merge-pathnames input)))
|
|
(*compile-file-truename* (truename input)))
|
|
(with-open-file (sin input :direction :input)
|
|
(bc-compile-file sin :output-file output-file))))
|
|
((not output-file-p)
|
|
(error "COMPILE-FILE invoked with a stream input and no :OUTPUT-FILE"))
|
|
(t
|
|
(with-open-file (sout output-file :direction :output :if-exists :supersede
|
|
:if-does-not-exist :create
|
|
:external-format external-format)
|
|
(let ((binary
|
|
(let ((*package* *package*)
|
|
(*readtable* *readtable*)
|
|
(ext:*bytecodes-compiler* t))
|
|
(si::bc-compile-from-stream input))))
|
|
(sys:with-ecl-io-syntax
|
|
(write binary :stream sout :circle t :escape t :readably t :pretty nil))
|
|
(terpri sout)))))
|
|
(when load
|
|
(load output-file :verbose *compile-verbose*))
|
|
(values output-file nil nil))
|
|
|
|
(defun install-bytecodes-compiler ()
|
|
(ext::package-lock (find-package :cl) nil)
|
|
(pushnew :ecl-bytecmp *features*)
|
|
(setf (fdefinition 'disassemble) #'bc-disassemble
|
|
(fdefinition 'compile) #'bc-compile
|
|
(fdefinition 'compile-file) #'bc-compile-file
|
|
(fdefinition 'compile-file-pathname) #'bc-compile-file-pathname)
|
|
(ext::package-lock (find-package :cl) t))
|
|
|
|
(defun install-c-compiler ()
|
|
(require :cmp)
|
|
(locally (declare (notinline install-c-compiler))
|
|
(funcall 'install-c-compiler)))
|
|
|
|
#-ecl-min
|
|
(progn
|
|
#+(and dlopen (not windows))
|
|
(sys::autoload "SYS:cmp" 'compile-file 'compile 'compile-file-pathname 'disassemble)
|
|
#-(and dlopen (not windows))
|
|
(install-bytecodes-compiler))
|
|
|
|
(provide '#:BYTECMP)
|
|
|
|
#-ecl-min
|
|
(package-lock "COMMON-LISP" t)
|