mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-12 07:50:26 -07:00
fb321885db
The procedure works as follows. First, cross compile ECL itself. In this step, we dump the configuration of the compiler. This configuration can then be later restored to put the host compiler into cross compilation mode using a new option to WITH-COMPILATION-UNIT. The following changes to the public interface are introduced: - WITH-COMPILATION-UNIT now takes a new :target keyword - New functions C:WRITE-TARGET-INFO, C:READ-TARGET-INFO to dump and restore the config - The environment parameters to TYPEP and SUBTYPEP are no longer unused. User macros can query type relationships in the target environment using these parameters. Internal changes in the compiler include: - Target dependent variables in the compiler are defined using a new DEFCONFIG macro. C:WRITE-TARGET-INFO simply writes the value of these variables to a file. - The distinction between target types and host types already exists in the compiler. In this commit, we just register the target types in the compiler environment when we change the compiler configuration.
190 lines
7.8 KiB
Common Lisp
190 lines
7.8 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
|
|
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
|
|
|
;;;;
|
|
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
|
;;;;
|
|
;;;; See file 'LICENSE' for the copyright details.
|
|
|
|
;;;;
|
|
;;;; CMPENV-DECLARE -- Declarations for the compiler
|
|
;;;;
|
|
;;;; Extract, process and incorporate declarations into the compiler
|
|
;;;; environment. Unlike proclamations, these are local to the current
|
|
;;;; compiled file and do not propagate beyond it.
|
|
;;;;
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun valid-form-p (x &optional test)
|
|
(and (si:proper-list-p x)
|
|
(or (null test)
|
|
(every test x))))
|
|
|
|
(defun type-name-p (name)
|
|
(or (cmp-env-search-type name *cmp-env*)
|
|
(si:get-sysprop name 'SI::DEFTYPE-DEFINITION)
|
|
(find-class name nil)
|
|
(si:get-sysprop name 'SI::STRUCTURE-TYPE)))
|
|
|
|
(defun validate-alien-declaration (names-list error)
|
|
(dolist (new-declaration names-list)
|
|
(unless (symbolp new-declaration)
|
|
(funcall error "The declaration ~s is not a symbol" new-declaration))
|
|
(when (type-name-p new-declaration)
|
|
(funcall error "Symbol name ~S cannot be both the name of a type and of a declaration"
|
|
new-declaration))))
|
|
|
|
(defun alien-declaration-p (name &optional (env *cmp-env*))
|
|
(and (symbolp name)
|
|
(member name (cmp-env-search-declaration 'alien env si:*alien-declarations*)
|
|
:test 'eq)))
|
|
|
|
(defun policy-declaration-p (name)
|
|
(and (gethash name *optimization-quality-switches*) t))
|
|
|
|
(defun parse-ignore-declaration (decl-args expected-ref-number tail)
|
|
(declare (si::c-local))
|
|
(loop for name in decl-args
|
|
do (if (symbolp name)
|
|
(push (cons name expected-ref-number) tail)
|
|
(cmpassert (and (consp name)
|
|
(= (length name) 2)
|
|
(eq (first name) 'function))
|
|
"Invalid argument to IGNORE/IGNORABLE declaration:~&~A"
|
|
name)))
|
|
tail)
|
|
|
|
(defun collect-declared (type var-list tail)
|
|
(declare (si::c-local))
|
|
(cmpassert (valid-form-p var-list #'symbolp)
|
|
"Syntax error in declaration ~s" `(TYPE ,type ,var-list))
|
|
(loop for var-name in var-list
|
|
do (push (cons var-name type) tail))
|
|
tail)
|
|
|
|
(defun c1body (body doc-p)
|
|
"Split a function body into a list of forms, a set of declarations,
|
|
and a possible documentation string (only accepted when DOC-P is true)."
|
|
(multiple-value-bind (all-declarations body doc specials)
|
|
(si:process-declarations body doc-p)
|
|
(loop with others = '()
|
|
with types = '()
|
|
with ignored = '()
|
|
for decl in all-declarations
|
|
for decl-name = (first decl)
|
|
for decl-args = (rest decl)
|
|
do (cmpassert (and (valid-form-p decl-args)
|
|
(or (symbolp decl-name)
|
|
(and (consp decl-name)
|
|
(valid-type-specifier decl-name))))
|
|
"Syntax error in declaration ~s" decl)
|
|
do (case decl-name
|
|
(cl:SPECIAL)
|
|
(cl:IGNORE
|
|
(cmpassert (valid-form-p decl-args)
|
|
"Syntax error in declaration ~s" decl)
|
|
(setf ignored (parse-ignore-declaration decl-args -1 ignored)))
|
|
(cl:IGNORABLE
|
|
(cmpassert (valid-form-p decl-args)
|
|
"Syntax error in declaration ~s" decl)
|
|
(setf ignored (parse-ignore-declaration decl-args 0 ignored)))
|
|
(cl:TYPE
|
|
(cmpassert (and (consp decl-args)
|
|
(valid-form-p (rest decl-args) #'symbolp))
|
|
"Syntax error in declaration ~s" decl)
|
|
(setf types (collect-declared (first decl-args)
|
|
(rest decl-args)
|
|
types)))
|
|
(OBJECT
|
|
(cmpassert (valid-form-p decl-args #'symbolp)
|
|
"Syntax error in declaration ~s" decl)
|
|
(setf types (collect-declared 'OBJECT decl-args types)))
|
|
((cl:OPTIMIZE cl:FTYPE cl:INLINE cl:NOTINLINE cl:DECLARATION SI::C-LOCAL
|
|
SI::C-GLOBAL cl:DYNAMIC-EXTENT cl:VALUES
|
|
SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY)
|
|
(push decl others))
|
|
(SI:FUNCTION-BLOCK-NAME)
|
|
(otherwise
|
|
(if (or (alien-declaration-p decl-name)
|
|
(policy-declaration-p decl-name))
|
|
(push decl others)
|
|
(multiple-value-bind (ok type)
|
|
(if (machine-c-type-p decl-name)
|
|
(values t decl-name)
|
|
(valid-type-specifier decl-name))
|
|
(if (null ok)
|
|
(cmpwarn "Unknown declaration specifier ~s." decl-name)
|
|
(setf types (collect-declared type decl-args types)))))))
|
|
finally (return (values body specials types ignored
|
|
(nreverse others) doc all-declarations)))))
|
|
|
|
(defun add-one-declaration (env decl)
|
|
"Add to the environment one declarations which is not type, ignorable or
|
|
special variable declarations, as these have been extracted before."
|
|
(case (car decl)
|
|
(cl:OPTIMIZE
|
|
(cmp-env-add-optimizations (rest decl) env))
|
|
(POLICY-DEBUG-IHS-FRAME
|
|
(let ((flag (or (rest decl) '(t))))
|
|
(if *current-function*
|
|
(progn
|
|
(cmp-env-add-declaration 'policy-debug-ihs-frame flag
|
|
(fun-cmp-env *current-function*))
|
|
env)
|
|
(cmp-env-add-declaration 'policy-debug-ihs-frame
|
|
flag env))))
|
|
(cl:FTYPE
|
|
(if (atom (rest decl))
|
|
(cmpwarn "Syntax error in declaration ~a" decl)
|
|
(multiple-value-bind (type-name args)
|
|
(si::normalize-type (second decl) env)
|
|
(if (eq type-name 'FUNCTION)
|
|
(dolist (v (cddr decl))
|
|
(setf env (add-function-declaration v args env)))
|
|
(cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
|
|
(second decl)))))
|
|
env)
|
|
(cl:INLINE
|
|
(loop for name in (rest decl) do (setf env (declare-inline name env)))
|
|
env)
|
|
(cl:NOTINLINE
|
|
(loop for name in (rest decl) do (setf env (declare-notinline name env)))
|
|
env)
|
|
(cl:DECLARATION
|
|
(validate-alien-declaration (rest decl) #'cmperr)
|
|
(cmp-env-extend-declaration 'alien (rest decl) env si:*alien-declarations*))
|
|
((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY)
|
|
env)
|
|
((cl:DYNAMIC-EXTENT cl:IGNORABLE SI:FUNCTION-BLOCK-NAME)
|
|
;; FIXME! SOME ARE IGNORED!
|
|
env)
|
|
(otherwise
|
|
(cond ((alien-declaration-p (first decl) env)
|
|
env)
|
|
((maybe-add-policy decl env))
|
|
(t
|
|
(cmpwarn "Unknown declaration specifier ~s" (first decl))
|
|
env)))))
|
|
|
|
(defun symbol-macro-declaration-p (name type)
|
|
(ext:when-let ((record (cmp-env-search-symbol-macro name)))
|
|
(let* ((expression (funcall record name nil)))
|
|
(cmp-env-register-symbol-macro name `(the ,type ,expression)))
|
|
t))
|
|
|
|
(defun check-vdecl (vnames ts is)
|
|
(loop for (name . type) in ts
|
|
unless (or (member name vnames :test #'eq)
|
|
(symbol-macro-declaration-p name type)
|
|
(cmp-env-search-var name))
|
|
do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s."
|
|
type name))
|
|
(loop for (name . expected-uses) in is
|
|
unless (or (member name vnames :test #'eq)
|
|
(cmp-env-search-symbol-macro name)
|
|
(cmp-env-search-macro name))
|
|
do (cmpwarn (if (minusp expected-uses)
|
|
"IGNORE declaration was found for not bound variable ~s."
|
|
"IGNORABLE declaration was found for not bound variable ~s.")
|
|
name)))
|