X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffopcompile.lisp;h=16f9daf7ea7fcdaab61edec64f9c528e98384862;hb=0c8643845555805048f50c783e118762e2c43a26;hp=c0dfd12661cc7cad5ef5c835a72636035588fa58;hpb=e4bfafdc796354cd1a809ab6f77b54ccf12a28ba;p=sbcl.git diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index c0dfd12..16f9daf 100644 --- a/src/compiler/fopcompile.lisp +++ b/src/compiler/fopcompile.lisp @@ -42,17 +42,20 @@ (constant-fopcompilable-p form)) (and (symbolp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form) + (macroexpand form *lexenv*) (if macroexpanded-p (fopcompilable-p macroexpansion) ;; Punt on :ALIEN variables (let ((kind (info :variable :kind form))) (or (eq kind :special) + ;; Not really a global, but a variable for + ;; which no information exists. + (eq kind :global) (eq kind :constant)))))) (and (listp form) (ignore-errors (list-length form)) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form) + (macroexpand form *lexenv*) (if macroexpanded-p (fopcompilable-p macroexpansion) (destructuring-bind (operator &rest args) form @@ -69,7 +72,18 @@ ;; are not fopcompileable as such, but we can compile ;; the lambdas with the real compiler, and the rest ;; of the expression with the fop-compiler. - (or (lambda-form-p (car args)) + (or (and (lambda-form-p (car args)) + ;; The lambda might be closing over some + ;; variable, punt. As a further improvement, + ;; we could analyze the lambda body to + ;; see whether it really closes over any + ;; variables. One place where even simple + ;; analysis would be useful are the PCL + ;; slot-definition type-check-functions + ;; -- JES, 2007-01-13 + (notany (lambda (binding) + (lambda-var-p (cdr binding))) + (lexenv-vars *lexenv*))) ;; #'FOO, #'(SETF FOO), etc (legal-fun-name-p (car args))))) ((if) @@ -97,16 +111,13 @@ eval)) nil) (every #'fopcompilable-p (cdr args)))) - ;; A LET or LET* that introduces no bindings or - ;; declarations is trivially fopcompilable. Forms - ;; with no bindings but with declarations could also - ;; be handled, but we're currently punting on any - ;; lexenv manipulation. + ;; A LET or LET* that introduces only lexical + ;; bindings might be fopcompilable, depending on + ;; whether something closes over the bindings. + ;; (And whether there are declarations in the body, + ;; see below) ((let let*) - (and (>= (length args) 1) - (null (car args)) - (every #'fopcompilable-p (cdr args)))) - ;; Likewise for LOCALLY + (let-fopcompilable-p operator args)) ((locally) (every #'fopcompilable-p args)) (otherwise @@ -129,6 +140,40 @@ (<= (length args) 255) (every #'fopcompilable-p args)))))))))) +(defun let-fopcompilable-p (operator args) + (when (>= (length args) 1) + (multiple-value-bind (body decls) + (parse-body (cdr args) :doc-string-allowed nil) + (declare (ignore body)) + (let* ((orig-lexenv *lexenv*) + (*lexenv* (make-lexenv))) + ;; We need to check for declarations + ;; first. Otherwise the fake lexenv we're + ;; constructing might be invalid. + (and (null decls) + (loop for binding in (car args) + for name = (if (consp binding) + (first binding) + binding) + for value = (if (consp binding) + (second binding) + nil) + ;; Only allow binding lexicals, + ;; since special bindings can't be + ;; easily expressed with fops. + always (and (eq (info :variable :kind name) + :global) + (let ((*lexenv* (ecase operator + (let orig-lexenv) + (let* *lexenv*)))) + (fopcompilable-p value))) + do (progn + (setf *lexenv* (make-lexenv)) + (push (cons name + (make-lambda-var :%source-name name)) + (lexenv-vars *lexenv*)))) + (every #'fopcompilable-p (cdr args))))))) + (defun lambda-form-p (form) (and (consp form) (member (car form) @@ -137,11 +182,7 @@ ;;; Check that a literal form is fopcompilable. It would not for example ;;; when the form contains structures with funny MAKE-LOAD-FORMS. (defun constant-fopcompilable-p (constant) - (let ((things-processed nil) - (count 0)) - (declare (type (or list hash-table) things-processed) - (type (integer 0 #.(1+ list-to-hash-table-threshold)) count) - (inline member)) + (let ((xset (alloc-xset))) (labels ((grovel (value) ;; Unless VALUE is an object which which obviously ;; can't contain other objects @@ -151,22 +192,9 @@ number character string)) - (etypecase things-processed - (list - (when (member value things-processed :test #'eq) - (return-from grovel nil)) - (push value things-processed) - (incf count) - (when (> count list-to-hash-table-threshold) - (let ((things things-processed)) - (setf things-processed - (make-hash-table :test 'eq)) - (dolist (thing things) - (setf (gethash thing things-processed) t))))) - (hash-table - (when (gethash value things-processed) - (return-from grovel nil)) - (setf (gethash value things-processed) t))) + (if (xset-member-p value xset) + (return-from grovel nil) + (add-to-xset value xset)) (typecase value (cons (grovel (car value)) @@ -196,7 +224,11 @@ (declare (ignore init-form)) (case creation-form (:sb-just-dump-it-normally - (fasl-validate-structure constant *compile-object*) + ;; FIXME: Why is this needed? If the constant + ;; is deemed fopcompilable, then when we dump + ;; it we bind *dump-only-valid-structures* to + ;; NIL. + (fasl-validate-structure value *compile-object*) (dotimes (i (- (%instance-length value) (layout-n-untagged-slots (%instance-ref value 0)))) @@ -217,15 +249,33 @@ (fopcompile-constant form for-value-p)) ((symbolp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form) + (sb!xc:macroexpand form *lexenv*) (if macroexpanded-p ;; Symbol macro (fopcompile macroexpansion path for-value-p) - ;; Special variable - (fopcompile `(symbol-value ',form) path for-value-p)))) + (let ((kind (info :variable :kind form))) + (if (member kind '(:special :constant)) + ;; Special variable + (fopcompile `(symbol-value ',form) path for-value-p) + ;; Lexical + (when for-value-p + (let* ((lambda-var (cdr (assoc form (lexenv-vars *lexenv*)))) + (handle (when lambda-var + (lambda-var-fop-value lambda-var)))) + (if handle + (sb!fasl::dump-push handle + *compile-object*) + (progn + ;; Undefined variable. Signal a warning, and + ;; treat it as a special variable reference, + ;; like the real compiler does. + (note-undefined-reference form :variable) + (fopcompile `(symbol-value ',form) + path + for-value-p)))))))))) ((listp form) (multiple-value-bind (macroexpansion macroexpanded-p) - (macroexpand form) + (sb!xc:macroexpand form *lexenv*) (if macroexpanded-p (fopcompile macroexpansion path for-value-p) (destructuring-bind (operator &rest args) form @@ -254,12 +304,12 @@ for-value-p))) ((if) (fopcompile-if args path for-value-p)) - ((progn) - (loop for (arg . next) on args - do (fopcompile arg - path (if next - nil - for-value-p)))) + ((progn locally) + (loop for (arg . next) on args + do (fopcompile arg + path (if next + nil + for-value-p)))) ((setq) (loop for (name value . next) on args by #'cddr do (fopcompile `(set ',name ,value) path @@ -273,7 +323,27 @@ (fopcompile (cons 'progn body) path for-value-p) (fopcompile nil path for-value-p)))) ((let let*) - (fopcompile (cons 'progn (cdr args)) path for-value-p)) + (let ((orig-lexenv *lexenv*) + (*lexenv* (make-lexenv :default *lexenv*))) + (loop for binding in (car args) + for name = (if (consp binding) + (first binding) + binding) + for value = (if (consp binding) + (second binding) + nil) + do (let ((*lexenv* (if (eql operator 'let) + orig-lexenv + *lexenv*))) + (fopcompile value path t)) + do (let ((obj (sb!fasl::dump-pop *compile-object*))) + (setf *lexenv* + (make-lexenv + :vars (list (cons name + (make-lambda-var + :%source-name name + :fop-value obj))))))) + (fopcompile (cons 'progn (cdr args)) path for-value-p))) ;; Otherwise it must be an ordinary funcall. (otherwise (cond @@ -316,17 +386,11 @@ (cond ;; Lambda forms are compiled with the real compiler ((lambda-form-p form) - ;; We wrap the real lambda inside another one to ensure - ;; that the compiler doesn't e.g. let convert it, thinking - ;; that there are no external references. - (let* ((handle (%compile `(lambda () ,form) + (let* ((handle (%compile form *compile-object* :path path))) (when for-value-p - (sb!fasl::dump-push handle *compile-object*) - ;; And then call the wrapper function when loading the FASL - (sb!fasl::dump-fop 'sb!fasl::fop-funcall *compile-object*) - (sb!fasl::dump-byte 0 *compile-object*)))) + (sb!fasl::dump-push handle *compile-object*)))) ;; While function names are translated to a call to FDEFINITION. ((legal-fun-name-p form) (dump-fdefinition form)) @@ -374,5 +438,9 @@ (defun fopcompile-constant (form for-value-p) (when for-value-p + ;; FIXME: Without this binding the dumper chokes on unvalidated + ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure + ;; about to be dumped, not its load-form. Compare and contrast + ;; with EMIT-MAKE-LOAD-FORM. (let ((sb!fasl::*dump-only-valid-structures* nil)) (dump-object form *compile-object*))))