[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-devel
Subject: Re: [Sbcl-devel] [Sbcl-commits] master: Don't save the whole lexical environment in inline expansion
From: Stas Boukarev <stassats () gmail ! com>
Date: 2022-04-11 2:06:54
Message-ID: CAF63=11FYpqXrEGQkxJBC2MS2FOBWxTrbKZwwjUxCs0qgDOsBw () mail ! gmail ! com
[Download RAW message or body]
That produces different fasls on CCL:
Run diff -ur sbcl-host/ ccl-host/
Binary files sbcl-host/obj/from-xc/src/compiler/x86-64/simd-pack-256.lisp-obj
and ccl-host/obj/from-xc/src/compiler/x86-64/simd-pack-256.lisp-obj
differ
Binary files sbcl-host/obj/from-xc/src/compiler/x86-64/simd-pack.lisp-obj
and ccl-host/obj/from-xc/src/compiler/x86-64/simd-pack.lisp-obj differ
sb-fasteval can't build:
The value
#<FUNCTION (LAMBDA (#:EXPR #:ENV)
:IN
"SYS:SRC;CODE;STUBS.LISP") {100324039B}>
is not of type
LIST
And on arm64:
[126/302] src/code/float-inf-nan (0.028 sec)
; file: src/code/numbers.lisp
; in: DEF FTRUNCATE
; (SB-KERNEL::DEF SB-XC:FTRUNCATE :TRUNCATE
; "Same as TRUNCATE, but returns first value as a float.")
;
; caught ERROR:
; (during macroexpansion of (DEFUN FTRUNCATE ...))
; CONVERT-MACRO-TO-LAMBDA called
On Mon, Apr 11, 2022 at 1:33 AM apache--- via Sbcl-commits
<sbcl-commits@lists.sourceforge.net> wrote:
>
> The branch "master" has been updated in SBCL:
> via 4c95f9edcfd9b126af392ad4128b1c48d492afdd (commit)
> from de354a441a83925ee08d1d995cc3ec1826f01bfd (commit)
>
> - Log -----------------------------------------------------------------
> commit 4c95f9edcfd9b126af392ad4128b1c48d492afdd
> Author: Charles Zhang <czhang@hrl.com>
> Date: Sun Apr 10 15:24:35 2022 -0700
>
> Don't save the whole lexical environment in inline expansions.
>
> Just what's needed from declarations and stuff. Do this by using the
> code-walker. We could probably avoid making the syntactic closure for
> this case as well by just stuffing the declarations somewhere in the
> body. This can be done if we really want to get rid of syntactic
> closures entirely.
> ---
> NEWS | 3 +
> contrib/sb-cltl2/defpackage.lisp | 1 +
> contrib/sb-cltl2/env.lisp | 2 +-
> contrib/sb-cltl2/macroexpand.lisp | 98 ------------------------------
> contrib/sb-cltl2/sb-cltl2.asd | 1 -
> src/code/defmacro.lisp | 2 +-
> src/cold/build-order.lisp-expr | 2 +-
> src/cold/exports.lisp | 1 +
> src/compiler/ir1-translators.lisp | 23 ++++---
> src/compiler/ir1tran-lambda.lisp | 70 +++++++++++-----------
> src/compiler/ir1tran.lisp | 2 +-
> src/compiler/node.lisp | 8 +--
> src/interpreter/env.lisp | 5 +-
> src/pcl/walk.lisp | 122 ++++++++++++++++++++++++++++++++++----
> 14 files changed, 171 insertions(+), 169 deletions(-)
>
> diff --git a/NEWS b/NEWS
> index 87945bcfe..9dd3d4f82 100644
> --- a/NEWS
> +++ b/NEWS
> @@ -8,6 +8,9 @@ changes relative to sbcl-2.2.3:
> or
> (LAMBDA (X) (ETYPECASE (INTEGER ...) (SYMBOL ...)) X)
> instead of forgetting all information about X after the E(TYPE)CASE.
> + * optimization: inlined functions enclosed in local macro definitions no
> + longer save their entire lexical environment, reducing unnecessary
> + memory retention.
>
> changes in sbcl-2.2.3 relative to sbcl-2.2.2:
> * minor incompatible change: SB-THREAD:MUTEX-OWNER may return :THREAD-DEAD
> diff --git a/contrib/sb-cltl2/defpackage.lisp b/contrib/sb-cltl2/defpackage.lisp
> index 765e79472..baac62c98 100644
> --- a/contrib/sb-cltl2/defpackage.lisp
> +++ b/contrib/sb-cltl2/defpackage.lisp
> @@ -1,5 +1,6 @@
> (defpackage :sb-cltl2
> (:use :cl :sb-c :sb-int :sb-kernel)
> + (:import-from #:sb-walker #:macroexpand-all)
> (:export #:compiler-let
> #:macroexpand-all
> ;; environment access
> diff --git a/contrib/sb-cltl2/env.lisp b/contrib/sb-cltl2/env.lisp
> index c8788349c..4d922174a 100644
> --- a/contrib/sb-cltl2/env.lisp
> +++ b/contrib/sb-cltl2/env.lisp
> @@ -65,7 +65,7 @@
> (setf (sb-c::lexenv-funs env)
> (nconc
> (loop for (name def) in macro
> - collect (cons name (list* 'sb-sys::macro def (function-lambda-expression def))))
> + collect (cons name (cons 'sb-sys::macro def)))
> (sb-c::lexenv-funs env))))
>
> (when symbol-macro
> diff --git a/contrib/sb-cltl2/macroexpand.lisp b/contrib/sb-cltl2/macroexpand.lisp
> deleted file mode 100644
> index 466fc88c1..000000000
> --- a/contrib/sb-cltl2/macroexpand.lisp
> +++ /dev/null
> @@ -1,98 +0,0 @@
> -(in-package :sb-cltl2)
> -
> -(defun macroexpand-all (form &optional environment)
> - (let ((sb-walker::*walk-form-expand-macros-p* t))
> - (sb-walker:walk-form
> - form environment
> - (lambda (subform context env)
> - (acond ((and (eq context :eval)
> - (listp subform)
> - (symbolp (car subform))
> - (get (car subform) :partial-macroexpander))
> - ;; The partial expander must return T as its second value
> - ;; if it wants to stop the walk.
> - (funcall it subform env))
> - (t
> - subform))))))
> -
> -;; Given EXPR, the argument to an invocation of Quasiquote macro, macroexpand
> -;; evaluable subforms of EXPR using ENV. A subform is evaluable if all
> -;; preceding occurrences of #\` have been "canceled" by a comma.
> -;; DEPTH counts the nesting and should not be supplied by external callers.
> -(defun %quasiquoted-macroexpand-all (expr env &optional (depth 0))
> - (flet ((quasiquote-p (x)
> - (and (listp x) (eq (car x) 'quasiquote) (singleton-p (cdr x))))
> - (recurse (x)
> - (%quasiquoted-macroexpand-all x env depth)))
> - (if (atom expr)
> - (cond ((simple-vector-p expr) (map 'vector #'recurse expr))
> - ((comma-p expr)
> - (unquote (if (> depth 1)
> - (%quasiquoted-macroexpand-all
> - (comma-expr expr) env (1- depth))
> - (macroexpand-all (comma-expr expr) env))
> - (comma-kind expr)))
> - (t expr))
> - (if (quasiquote-p expr)
> - (list 'quasiquote
> - (%quasiquoted-macroexpand-all (second expr) env (1+ depth)))
> - (let (result)
> - (loop
> - (push (recurse (pop expr)) result)
> - (when (or (atom expr) (quasiquote-p expr))
> - (return (nreconc result (recurse expr))))))))))
> -
> -(setf (get 'quasiquote :partial-macroexpander)
> - (lambda (form env)
> - (destructuring-bind (arg) (cdr form) ; sanity-check the shape
> - (declare (ignore arg))
> - (values (%quasiquoted-macroexpand-all form env) t))))
> -
> -#|
> -
> -;; Another example that some people might find useful.
> -
> -(defun macroexpand-decls+forms (body env) ; a bit of a kludge, but it works
> - (mapcar (lambda (x)
> - (if (and (listp x) (eq (car x) 'declare))
> - x
> - (macroexpand-all x env)))
> - body))
> -
> -(setf (get 'dotimes :partial-macroexpander)
> - (lambda (form env)
> - (destructuring-bind ((var count &optional (result nil result-p))
> - &body body) (cdr form)
> - (values `(dotimes (,var ,(macroexpand-all count env)
> - ,@(if result-p
> - (list (macroexpand-all result env))))
> - ,@(macroexpand-decls+forms body env))
> - t))))
> -
> -(macroexpand-all '(macrolet ((hair (x) `(car ,x)))
> - (dotimes (i (bar)) (foo i (hair baz)) l))))
> -=>
> -(MACROLET ((HAIR (X)
> - `(CAR ,X)))
> - (DOTIMES (I (BAR)) (FOO I (CAR BAZ)) L))
> -
> -instead of
> -
> -(MACROLET ((HAIR (X)
> - `(CAR ,X)))
> - (BLOCK NIL
> - (LET ((I 0) (#:COUNT699 (BAR)))
> - (DECLARE (TYPE UNSIGNED-BYTE I)
> - (TYPE INTEGER #:COUNT699))
> - (TAGBODY
> - (GO #:G701)
> - #:G700
> - (TAGBODY (FOO I (CAR BAZ)) L)
> - (LET* ()
> - (MULTIPLE-VALUE-BIND (#:NEW702) (1+ I) (PROGN (SETQ I #:NEW702) NIL)))
> - #:G701
> - (IF (>= I #:COUNT699)
> - NIL
> - (PROGN (GO #:G700)))
> - (RETURN-FROM NIL (PROGN NIL))))))
> -|#
> diff --git a/contrib/sb-cltl2/sb-cltl2.asd b/contrib/sb-cltl2/sb-cltl2.asd
> index 2ebbe5e25..ffec6494d 100644
> --- a/contrib/sb-cltl2/sb-cltl2.asd
> +++ b/contrib/sb-cltl2/sb-cltl2.asd
> @@ -8,7 +8,6 @@
> #+sb-building-contrib #p"SYS:CONTRIB;SB-CLTL2;"
> :components ((:file "defpackage")
> (:file "compiler-let" :depends-on ("defpackage"))
> - (:file "macroexpand" :depends-on ("defpackage"))
> (:file "env" :depends-on ("defpackage")))
> :perform (load-op :after (o c) (provide 'sb-cltl2))
> :in-order-to ((test-op (test-op "sb-cltl2/tests"))))
> diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp
> index c88f94eda..fedceceb3 100644
> --- a/src/code/defmacro.lisp
> +++ b/src/code/defmacro.lisp
> @@ -27,7 +27,7 @@ only."
> (let ((def (cdr (assoc symbol (lexenv-funs env)))))
> (when def
> (return-from macro-function
> - (when (typep def '(cons (eql macro))) (cadr def)))))))
> + (when (typep def '(cons (eql macro))) (cdr def)))))))
> (values (info :function :macro-function symbol)))
>
> (defun (setf macro-function) (function symbol &optional environment)
> diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr
> index d58305412..42e3cb975 100644
> --- a/src/cold/build-order.lisp-expr
> +++ b/src/cold/build-order.lisp-expr
> @@ -580,7 +580,7 @@
> ;;; as PCL gets more integrated into the system, we'd like to
> ;;; bootstrap things like classes at the same time as the rest of the
> ;;; type system.
> - ("src/pcl/walk" :not-host)
> + ("src/pcl/walk")
> ("src/pcl/low" :not-host)
> ("src/pcl/macros" :not-host)
> ("src/pcl/ecd" :not-host)
> diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
> index e57fa41b2..1952bf395 100644
> --- a/src/cold/exports.lisp
> +++ b/src/cold/exports.lisp
> @@ -2809,6 +2809,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
> (:use "CL" "SB-INT" "SB-EXT")
> (:shadow "RECONS")
> (:export "DEFINE-WALKER-TEMPLATE"
> + "MACROEXPAND-ALL"
> "WALK-FORM"
> "*WALK-FORM-EXPAND-MACROS-P*"
> "VAR-LEXICAL-P" "VAR-SPECIAL-P"
> diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
> index 3c2d91f72..d957760ed 100644
> --- a/src/compiler/ir1-translators.lisp
> +++ b/src/compiler/ir1-translators.lisp
> @@ -324,18 +324,17 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL,
> (unless (listp arglist)
> (fail "The local macro argument list ~S is not a list."
> arglist))
> - (let ((lambda (make-macro-lambda nil arglist body 'macrolet name)))
> - `(,name macro
> - ;; I guess the reason we want to compile here rather than possibly
> - ;; using an interpreted lambda is that we generate the usual gamut
> - ;; of style-warnings and such. One might wonder if this could somehow
> - ;; go through the front-most part of the front-end, to deal with
> - ;; semantics, but then generate an interpreted function or something
> - ;; more quick to emit than machine code.
> - ,(compile-in-lexenv lambda lexenv
> - ;; name source-info tlf ephemeral errorp
> - nil nil nil t nil)
> - . ,lambda)))))))
> + `(,name macro .
> + ;; I guess the reason we want to compile here rather than possibly
> + ;; using an interpreted lambda is that we generate the usual gamut
> + ;; of style-warnings and such. One might wonder if this could somehow
> + ;; go through the front-most part of the front-end, to deal with
> + ;; semantics, but then generate an interpreted function or something
> + ;; more quick to emit than machine code.
> + ,(compile-in-lexenv
> + (make-macro-lambda nil arglist body 'macrolet name)
> + lexenv
> + nil nil nil t nil))))))) ; name source-info tlf ephemeral errorp
>
> (defun funcall-in-macrolet-lexenv (definitions fun context)
> (%funcall-in-foomacrolet-lexenv
> diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
> index fd15af748..73795a8f4 100644
> --- a/src/compiler/ir1tran-lambda.lisp
> +++ b/src/compiler/ir1tran-lambda.lisp
> @@ -1049,8 +1049,8 @@
>
> (declaim (end-block))
>
> -
> ;;;; defining global functions
> +
> ;;; Given a lambda-list, return a FUN-TYPE object representing the signature:
> ;;; return type is *, and each individual arguments type is T -- but we get
> ;;; the argument counts and keywords.
> @@ -1074,17 +1074,19 @@
>
> (declaim (start-block maybe-inline-syntactic-closure))
>
> -;;; Take the lexenv surrounding an inlined function and extract things
> -;;; needed for the inline expansion suitable for dumping into fasls.
> -;;; Right now it's MACROLET, SYMBOL-MACROLET, SPECIAL and
> -;;; INLINE/NOTINLINE declarations. Upon encountering something else return NIL.
> -;;; This is later used by PROCESS-INLINE-LEXENV to reproduce the lexenv.
> +;;; Expand a lambda form in LEXENV, returning the expansion and
> +;;; extract the other stuff like SPECIAL and INLINE/NOTINLINE
> +;;; declarations needed for reconstructing the lambda in the remaining
> +;;; lexical environment. Return this other stuff as a secondary value,
> +;;; but if the lexical environment still contains things that are too
> +;;; hairy to handle, return NIL. This is later used by
> +;;; PROCESS-INLINE-LEXENV to reproduce the lexenv.
> ;;;
> ;;; Previously it just used the functions and vars of the innermost
> ;;; lexenv, but the body of macrolet can refer to other macrolets
> ;;; defined earlier, so it needs to process all the parent lexenvs to
> ;;; recover the proper order.
> -(defun reconstruct-lexenv (lexenv)
> +(defun expand-in-syntactic-environment (lambda lexenv)
> (let (shadowed-funs
> shadowed-vars
> result)
> @@ -1093,8 +1095,6 @@
> for vars = (lexenv-vars env)
> for funs = (lexenv-funs env)
> for declarations = nil
> - for symbol-macros = nil
> - for macros = nil
> do
> (loop for binding in vars
> for (name . what) = binding
> @@ -1103,14 +1103,14 @@
> do (typecase what
> (cons
> (aver (eq (car what) 'macro))
> - (push name shadowed-vars)
> - (push (list name (cdr what)) symbol-macros))
> + (push name shadowed-vars))
> (global-var
> (aver (eq (global-var-kind what) :special))
> (push `(special ,name) declarations))
> (t
> (unless (memq name shadowed-vars)
> - (return-from reconstruct-lexenv)))))
> + (return-from expand-in-syntactic-environment
> + (values nil nil))))))
> (loop for binding in funs
> for (name . what) = binding
> unless (and parent
> @@ -1118,8 +1118,7 @@
> do
> (typecase what
> (cons
> - (push name shadowed-funs)
> - (push (cons name (cddr what)) macros))
> + (push name shadowed-funs))
> ;; FIXME: Is there a good reason for this not to be
> ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case
> ;; you're wondering how this ever worked :-)? Maybe
> @@ -1128,28 +1127,28 @@
> ;; 2002-07-08
> (global-var
> (unless (defined-fun-p what)
> - (return-from reconstruct-lexenv))
> + (return-from expand-in-syntactic-environment
> + (values nil nil)))
> (push `(,(car (defined-fun-inlinep what))
> ,name)
> declarations))
> (t
> (unless (memq name shadowed-funs)
> - (return-from reconstruct-lexenv)))))
> + (return-from expand-in-syntactic-environment
> + (values nil nil))))))
> (when declarations
> (setf result (list* :declare declarations (and result (list result)))))
> - (when symbol-macros
> - (setf result (list* :symbol-macro symbol-macros (and result (list result)))))
> - (when macros
> - (setf result (list* :macro macros (and result (list result)))))
> while (and parent
> (not (null-lexenv-p parent))))
> - result))
> + (values (sb-walker:macroexpand-all lambda lexenv)
> + result)))
>
> -;;; Return a lambda form that has been "closed" with respect ot
> +;;; Return a lambda form that has been "closed" with respect to
> ;;; LEXENV, returning a LAMBDA-WITH-LEXENV if there are interesting
> -;;; macros or declarations, so that reloading the definition from a
> -;;; compiled file preserves the original lexical environment for
> -;;; inlining. If there is something too complex in the lexical
> +;;; declarations. To handle local macros, rather than closing over
> +;;; definitions in the environment, expand all macros in the body of
> +;;; LAMBDA, so that nothing in the syntactic environment is needed in
> +;;; the expansion. If there is something too complex in the lexical
> ;;; environment (like a lexical variable), then we return NIL.
> (defun maybe-inline-syntactic-closure (lambda lexenv)
> (declare (type list lambda) (type lexenv-designator lexenv))
> @@ -1158,10 +1157,15 @@
> (lexenv
> (let ((vars (lexenv-vars lexenv))
> (funs (lexenv-funs lexenv)))
> - (acond ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil)
> - ((and (null vars) (null funs)) lambda)
> - ((reconstruct-lexenv lexenv)
> - `(lambda-with-lexenv ,it ,@(cdr lambda))))))
> + (cond ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil)
> + ((and (null vars) (null funs)) lambda)
> + (t
> + (multiple-value-bind (expansion remaining-lexenv)
> + (expand-in-syntactic-environment lambda lexenv)
> + (when expansion
> + (if remaining-lexenv
> + `(lambda-with-lexenv ,remaining-lexenv ,@(cdr expansion))
> + expansion)))))))
> #+(and sb-fasteval (not sb-xc-host))
> (sb-interpreter:basic-env
> (awhen (sb-interpreter::reconstruct-syntactic-closure-env lexenv)
> @@ -1189,11 +1193,9 @@
> (mapcar (lambda (binding)
> ;; XC compile-in-lexenv ignores its second arg
> #+sb-xc-host (aver (null-lexenv-p lexenv))
> - (destructuring-bind (name . form) binding
> - (list* name 'macro
> - (compile-in-lexenv form lexenv
> - nil nil nil t nil)
> - form)))
> + (list* (car binding) 'macro
> + (compile-in-lexenv (cdr binding) lexenv
> + nil nil nil t nil)))
> bindings)))
> (recurse body
> (make-lexenv :default lexenv
> diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
> index c8b04a358..b4f784dd1 100644
> --- a/src/compiler/ir1tran.lisp
> +++ b/src/compiler/ir1tran.lisp
> @@ -900,7 +900,7 @@
> *inline-expansions*)
> (list* lexical-def 1 *inline-expansions*))))
> (ir1-convert start next result
> - (careful-expand-macro (cadr lexical-def) form)))
> + (careful-expand-macro (cdr lexical-def) form)))
> (progn
> (compiler-warn "Recursion limit reached while expanding local macro ~
> ~/sb-ext:print-symbol-with-prefix/" op)
> diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
> index 6fce628ec..ad4c50221 100644
> --- a/src/compiler/node.lisp
> +++ b/src/compiler/node.lisp
> @@ -40,10 +40,10 @@
> disabled-package-locks %policy user-data
> parent)))
> ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a
> - ;; local function), a DEFINED-FUN, representing an INLINE/NOTINLINE
> - ;; declaration, or a list (MACRO <function> . <form>) (a local
> - ;; macro, with the specifier expander). Note that NAME may be a
> - ;; (SETF <name>) list, not necessarily a single symbol.
> + ;; local function), a DEFINED-FUN, representing an
> + ;; INLINE/NOTINLINE declaration, or a list (MACRO . <function>) (a
> + ;; local macro, with the specifier expander). Note that NAME may be
> + ;; a (SETF <name>) list, not necessarily a single symbol.
> (funs nil :type list)
> ;; an alist translating variable names to LEAF structures. A special
> ;; binding is indicated by a :SPECIAL GLOBAL-VAR leaf. Each special
> diff --git a/src/interpreter/env.lisp b/src/interpreter/env.lisp
> index 0d45afa0a..415068f41 100644
> --- a/src/interpreter/env.lisp
> +++ b/src/interpreter/env.lisp
> @@ -1129,8 +1129,7 @@
> (cons sym (make-global-var :%source-name sym
> :kind :special
> :where-from :declared))))
> - (macroize (name thing) (list* name 'sb-sys:macro thing (fun-lambda-expression thing)))
> - (symbol-macroize (name thing) (list* name 'sb-sys:macro thing))
> + (macroize (name thing) (list* name 'sb-sys:macro thing))
> (fname (f) (second (fun-name f))))
> (multiple-value-bind (vars funs)
> (typecase env
> @@ -1147,7 +1146,7 @@
> ;; access interpreter's lexical vars
> ;; Prevent SETF on the variable from getting
> ;; "Destructive function (SETF SVREF) called on constant data"
> - (symbol-macroize sym `(svref (load-time-value ,payload) ,i)))
> + (macroize sym `(svref (load-time-value ,payload) ,i)))
> (t
> (let ((leaf (make-lambda-var
> :%source-name sym
> diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
> index 985418914..602ad6827 100644
> --- a/src/pcl/walk.lisp
> +++ b/src/pcl/walk.lisp
> @@ -82,9 +82,9 @@
> ;;; variables, blocks, etc. Except for SYMBOL-MACROLET, only the
> ;;; SB-C::LEXENV-FUNS slot is relevant. It holds: Alist (Name . What),
> ;;; where What is either a functional (a local function) or a list
> -;;; (MACRO <function> . <form>) (a local macro, with the specifier
> -;;; expander.) Note that Name may be a (SETF <name>)
> -;;; function. Accessors are defined below, eg (ENV-WALK-FUNCTION ENV).
> +;;; (MACRO . <function>) (a local macro, with the specifier expander.)
> +;;; Note that Name may be a (SETF <name>) function. Accessors are
> +;;; defined below, eg (ENV-WALK-FUNCTION ENV).
> ;;;
> ;;; If WITH-AUGMENTED-ENVIRONMENT is called from WALKER-ENVIRONMENT-BIND
> ;;; this code hides the WALKER version of an environment
> @@ -101,7 +101,7 @@
> ;;;
> ;;; Instead, we now use a special sort of "function"-type for that
> ;;; information, because the functions slot in SB-C::LEXENV is
> -;;; supposed to have a list of <Name MACRO #<function> . <form> elements.
> +;;; supposed to have a list of <Name MACRO . #<function> elements.
> ;;; So, now we hide our bits of interest in the walker-info slot in
> ;;; our new BOGO-FUN.
> ;;;
> @@ -173,13 +173,12 @@
> (sb-c::make-functional :lexenv lexenv)))
> funs)
> (mapcar (lambda (m)
> - (destructuring-bind (name form) m
> - (list* name
> - 'sb-sys:macro
> - (if (eq name *key-to-walker-environment*)
> - (walker-info-to-bogo-fun form)
> - (coerce form 'function))
> - form)))
> + (list* (car m)
> + 'sb-sys:macro
> + (if (eq (car m)
> + *key-to-walker-environment*)
> + (walker-info-to-bogo-fun (cadr m))
> + (coerce (cadr m) 'function))))
> macros)))))
>
> (defun environment-function (env fn)
> @@ -195,8 +194,8 @@
> (and entry
> (eq (cadr entry) 'sb-sys:macro)
> (if (eq macro *key-to-walker-environment*)
> - (values (bogo-fun-to-walker-info (caddr entry)))
> - (values (cadddr entry)))))))
> + (values (bogo-fun-to-walker-info (cddr entry)))
> + (values (function-lambda-expression (cddr entry))))))))
>
> ;;;; other environment hacking, not so SBCL-specific as the
> ;;;; environment hacking in the previous section
> @@ -472,6 +471,103 @@
> (defvar *walk-form-expand-macros-p* nil)
> (defvar *walk-form-preserve-source* nil)
>
> +(defun macroexpand-all (form &optional environment)
> + (let ((*walk-form-expand-macros-p* t))
> + (sb-walker:walk-form
> + form environment
> + (lambda (subform context env)
> + (acond ((and (eq context :eval)
> + (listp subform)
> + (symbolp (car subform))
> + (get (car subform) :partial-macroexpander))
> + ;; The partial expander must return T as its second value
> + ;; if it wants to stop the walk.
> + (funcall it subform env))
> + (t
> + subform))))))
> +
> +;; Given EXPR, the argument to an invocation of Quasiquote macro, macroexpand
> +;; evaluable subforms of EXPR using ENV. A subform is evaluable if all
> +;; preceding occurrences of #\` have been "canceled" by a comma.
> +;; DEPTH counts the nesting and should not be supplied by external callers.
> +(defun %quasiquoted-macroexpand-all (expr env &optional (depth 0))
> + (flet ((quasiquote-p (x)
> + (and (listp x) (eq (car x) 'quasiquote) (singleton-p (cdr x))))
> + (recurse (x)
> + (%quasiquoted-macroexpand-all x env depth)))
> + (if (atom expr)
> + (cond ((simple-vector-p expr) (map 'vector #'recurse expr))
> + ((comma-p expr)
> + (unquote (if (> depth 1)
> + (%quasiquoted-macroexpand-all
> + (comma-expr expr) env (1- depth))
> + (macroexpand-all (comma-expr expr) env))
> + (comma-kind expr)))
> + (t expr))
> + (if (quasiquote-p expr)
> + (list 'quasiquote
> + (%quasiquoted-macroexpand-all (second expr) env (1+ depth)))
> + (let (result)
> + (loop
> + (push (recurse (pop expr)) result)
> + (when (or (atom expr) (quasiquote-p expr))
> + (return (nreconc result (recurse expr))))))))))
> +
> +(setf (get 'quasiquote :partial-macroexpander)
> + (lambda (form env)
> + (destructuring-bind (arg) (cdr form) ; sanity-check the shape
> + (declare (ignore arg))
> + (values (%quasiquoted-macroexpand-all form env) t))))
> +
> +#|
> +
> +;; Another example that some people might find useful.
> +
> +(defun macroexpand-decls+forms (body env) ; a bit of a kludge, but it works
> + (mapcar (lambda (x)
> + (if (and (listp x) (eq (car x) 'declare))
> + x
> + (macroexpand-all x env)))
> + body))
> +
> +(setf (get 'dotimes :partial-macroexpander)
> + (lambda (form env)
> + (destructuring-bind ((var count &optional (result nil result-p))
> + &body body) (cdr form)
> + (values `(dotimes (,var ,(macroexpand-all count env)
> + ,@(if result-p
> + (list (macroexpand-all result env))))
> + ,@(macroexpand-decls+forms body env))
> + t))))
> +
> +(macroexpand-all '(macrolet ((hair (x) `(car ,x)))
> + (dotimes (i (bar)) (foo i (hair baz)) l))))
> +=>
> +(MACROLET ((HAIR (X)
> + `(CAR ,X)))
> + (DOTIMES (I (BAR)) (FOO I (CAR BAZ)) L))
> +
> +instead of
> +
> +(MACROLET ((HAIR (X)
> + `(CAR ,X)))
> + (BLOCK NIL
> + (LET ((I 0) (#:COUNT699 (BAR)))
> + (DECLARE (TYPE UNSIGNED-BYTE I)
> + (TYPE INTEGER #:COUNT699))
> + (TAGBODY
> + (GO #:G701)
> + #:G700
> + (TAGBODY (FOO I (CAR BAZ)) L)
> + (LET* ()
> + (MULTIPLE-VALUE-BIND (#:NEW702) (1+ I) (PROGN (SETQ I #:NEW702) NIL)))
> + #:G701
> + (IF (>= I #:COUNT699)
> + NIL
> + (PROGN (GO #:G700)))
> + (RETURN-FROM NIL (PROGN NIL))))))
> +|#
> +
> #+sb-fasteval
> (declaim (ftype (sfunction (sb-interpreter:basic-env &optional t) sb-kernel:lexenv)
> sb-interpreter:lexenv-from-env environment))
>
> -----------------------------------------------------------------------
>
>
> hooks/post-receive
> --
> SBCL
>
>
> _______________________________________________
> Sbcl-commits mailing list
> Sbcl-commits@lists.sourceforge.net
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic