;;; -*- Mode: Lisp; Package: Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This file contains the basic control structure and connective tissue
;;; for the Common Lisp Compiler.
;;; Written by Scott Fahlman, Dave Dill, Skef Wholey, et al.
;;; Currently maintained by Scott Fahlman.
;;; The change log for the compiler is kept in LOG.TXT on the compiler
;;; directory. Any changes should be recorded there.
;;; *******************************************************************
;;; Version number goes here:
(defvar compiler-version "1.0")
;;; Assembler version filled in by the assembler.
(defvar assembler-version "???")
;;; STYLE NOTES:
;;; This version of the compiler runs only in Common Lisp. It is written
;;; using only the simplest language constructs so that it can be bootstrapped
;;; in older versions of Common Lisp and so that we can move it back into
;;; Maclisp if the need arises. Therefore, it should not be considered
;;; an example of good coding style in Common Lisp.
;;;; GLOBAL SWITCHES
;;; These control the actions of the compiler. They may be set by the user,
;;; but more commonly are manipulated via declarations.
(defvar *peep-enable* t
"If non-null, run the peephole optimizer over the byte codes. This produces
much better code, but takes considerably longer to compile.")
(defvar *inline-enable* t
"If null, inhibit inline expansion of functions, regardless of any INLINE
declarations.")
(defvar *open-code-sequence-functions* t
"If non-null, convert most sequence functions into the equivalent DO loops.")
(defvar *complain-about-inefficiency* nil
"If non-null, print a comment when certain things must be done in an
inefficient way because of lack of declarations or other problems that
the user might be unaware of.")
(defvar *eliminate-tail-recursion* t
"If non-null, attempt to turn tail recursive calls from a function to itself
into iteration.")
(defvar *all-rest-args-are-lists* nil
"If non-null, this has the effect of declaring every &rest arg to be of
type list. They all start that way, but the user could alter them.")
(defvar *eval-when-load* t
"If non-null, says that any forms encountered by the compiler are to appear
in the output file, compiled if possible, for execution at load time.
Initially T, modified by EVAL-WHEN forms.")
(defvar *eval-when-compile* nil
"If non-null, says that any forms encountered by the compiler are to be
executed in the compiler's Lisp environment. Initially NIL, modified by
EVAL-WHEN forms.")
(defvar *nthcdr-open-code-limit* 10
"Maximum size NTHCDR or NTH to open-code as CAR and CDR forms.")
(defvar *peep-statistics* nil
"If non-null, print a message to error stream telling how much
space the peeper reclaimed for each function.")
(defvar *verbose* t
"If nil, only true error messages and warnings go to the error stream.
If non-null, prints a message as each function is compiled.")
(defvar *compile-to-lisp* nil
"If non-null, stuff compiled definitions into the compiler's own Lisp
environment.")
(defvar *check-keywords-at-runtime* t
"If non-null, compiled code with &key arguments will check at runtime
for unknown keywords. This facility is normally left on.")
;;; The following only make a difference on the Vax and other machines with
;;; fixed instruction sets.
(defvar *array-bounds-check-enable* t
"If null, do not check bounds on array references.")
(defvar *cdr-check-enable* t
"If null, do not type-check CAR and CDR if arg is declared to be a list.")
(defvar *never-check-car-cdr* nil
"If non-null, inhibits all type-checking on CAR-CDR operations, regardless
of declarations on the arguments. Use this only for well-debugged code
that really needs the extra speed. It is dangerous.")
(defvar *all-integers-are-fixnums* nil
"If non-null, the user guarantees that all integer arithmetic can be
assumed fixnum. Produces faster code, but may be dangerous.")
(defvar *number-type-annotations* nil
"If non-null, annotate most arithmetic ops with number-type information.")
(defvar *examine-environment-function-information* t
"If this is non-NIL, look in the compiler environment for function arg-counts
and types (macro, expr, fexpr) if you don't find the information on the
expected slots.")
(defvar *optimize-let-bindings* t
"If this is t, optimize some let bindings, such as those generated by
lambda expansions and setfs. If it is :all, optimize all lets. If it
is nil, don't optimize any. Takes significant time to do all. The
optimization involves replacing instances of variables that are bound
to something trivial* or used only once with what they are bound to.")
;;; The following are manipultaed by the OPTIMIZE declaration.
(defvar optimize-speed 1
"Current value of Speed in Optimize declaration, 0 - 3.")
(defvar optimize-space 1
"Current value of Space in Optimize declaration, 0 - 3.")
(defvar optimize-safety 1
"Current value of Safety in Optimize declaration, 0 - 3.")
(defvar optimize-cspeed 1
"Current value of Compiler Speed in Optimize declaration, 0 - 3.")
;;; Streams for file-to-file compilation. If a stream is NIL, don't produce
;;; this kind of output.
(defvar *clc-input-stream* nil)
(defvar *clc-fasl-stream* nil)
(defvar *clc-lap-stream* nil)
(defvar *clc-err-stream* nil)
;;; *Random-Top-Level-Forms* holds a list of all the random forms encountered
;;; at top-level since the last non-random form (e.g. a Defun). When the next
;;; non-random form is encountered, the forms in this list are flushed out
;;; bundled into a one-shot function.
(defvar *random-top-level-forms* nil)
(defvar *in-the-compiler* nil
"Assorted macros look at this to see if they are running in the compiler.")
;;;; IMPLEMENTATION-DEPENDENT CONSTANTS
(defconstant host-machine 'perq
"The type of machine on which the compiler is running.")
(defconstant host-system 'spice
"The operating system on which the compiler is running.")
(defconstant target-machine 'perq
"The type of machine that the code is being compiled for.")
(defconstant target-system 'spice
"The operating system that the code is being compiled for.")
(defconstant annotate-special-bindings nil
"If non-null, the implementation will make use of the special bindiings
annotation on return, so be careful to keep this accurate.")
(defconstant unbound-marker '(%sp-make-immediate-type 0 0)
"The implementation-dependent expression that makes an unbound marker.")
;;; Exclusive limits for immediate number representations.
(defconstant most-positive-short-constant 255)
(defconstant most-negative-short-constant -256)
(defconstant short-constant-mask 255)
;;; TYPE-NAMES is a constant list of the legal type names, for use in
;;; declaration processing.
(defconstant type-names
'(array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float function hash-table integer
keyword list long-float nil null number package pathname random-state
ratio rational readtable sequence short-float simple-array
simple-bit-vector simple-string simple-vector single-float
standard-char stream string string-char symbol t vector))
;;;; ASSORTED SPECIAL VARIABLES
;;; All of the following are given plausible top-level values so that parts
;;; of the compiler can be tested without a lot of setup.
(defvar *function-definitions-to-set-up* nil
"This is a list of function definitions that need to be put on symbol-function
and random top-level forms that need to be eval'ed, in order, at the end of
compile-from-stream. It gets built in COMPILE-ONE-LAMBDA.")
(defvar functions-with-errors nil
"A list of all functions that did not compile properly due to errors in
the code.")
(defvar error-count 0
"The number of errors generated during this compilation.")
(defvar warning-count 0
"The number of warnings generated during this compilation.")
(defvar unknown-functions nil
"List of functions called but not yet seen and not built-in. The user
is informed of any function still on this list at the end of a file
compilation.")
(defvar unknown-free-vars nil
"A list of all variables referenced free in the compilation, but not
bound or declared special anywhere. These are assumed to be special
variables, but are listed in a warning message at the end of the
compilation.")
(defvar input-filename nil
"Truename of file being compiled, as a string.")
(defvar for-value nil
"If null, says that the value of the current form is to be discarded.
T means caller wants a single value. MULTIPLE or TAIL means that multiple
values will be accepted. TAIL means that the call is in tail-recursive
position. PREDICATE is like T but says that the caller only cares whether
or not the value is NIL.")
(defvar fixnum-output nil
"Used to pass into CG-FORM the information that the fors result is declared
to be of type fixnum.")
(defvar function-name nil
"Holds a symbol that names the function currently being compiled,
or nil if between functions.")
(defvar function-type 'expr
"The type of function being compiled: Expr, Fexpr, Macro, Closure, or
One-Shot.")
(defvar lap-code '((code-start))
"A list of the Lap code being generated for the current function. The
first entry on this list is the marker (CODE-START), which gives us a
cons cell which can be destructively modified. Lap-code is kept in
reversed form while being built, then is nreversed for peephole
optimization and assembly.")
(defvar lap-code-start '((dummy-code-start))
"Holds onto the last cons cell in the Lap-Code list under construction.
This corresponds to the start of the function. Used when it is necessary
to insert instructions at the start of the function.")
(defvar lap-function nil
"This is the full LAP representation of a function, consisting of some
prefix stuff and the LAP-CODE list as the tail.")
(defvar constants-list nil
"A list of all the constants and specials needed by the function being
defined. Built during pass 2. Kept in reversed form.")
(defvar nconstants 0
"The number of entries currently on CONSTANTS-LIST.")
(defvar next-local 0
"The index of the next local to be allocated for the current function.")
(defvar nlocals 0
"The total number of locals needed by the current function. This is the
high-water mark for Next-Local.")
(defvar closed-var-count-list nil
"Keeps track of the number of variables that must go into the closure
vector at each (function (lambda ...)) level in the current form.
The car of this list is the number in the function currently being compiled,
the cadr is the number in the function where it is closed, etc.")
(defvar closure-vector-home 0
"Index of the local var containing the closure vector for this function.")
(defvar function-level 0
"Indicates how deep we are nested in FUNCTION forms. A top-level defun
starts at 0.")
(defvar max-args 0
"The maximum number of args for the current function, excluding any &rest
or &key args.")
(defvar min-args 0
"The minimum number of args for the current function.")
(defvar rest-arg-present nil
"Indicates whether the current function has an &rest arg. Any use of
&key creates an implicit &rest if none already exists.")
(defvar current-function-form nil
"The actual form that is the current function. Used by %tail-recursion-marker
to call recursively on the function.")
(defvar function-entry-venv nil
"The variable environment saved from the time when the current function
was entered (after the lambda-list is processed, before the block is processed).
Used to reset parameters during tail-recursion elimination.")
(defvar rest-arg-entry-point nil
"Entry point for the rest arg, or nil if there isn't one.")
(defvar tail-recursion-tag nil
"A tag deposited at the start of the program's body so that tail-recursive
calls can jump to it.")
(defvar current-arglist nil
"The list of argument names for this function.")
(defvar nspecials 0
"The number of specials that must be unbound by return from this
function, or NIL is this cannot be determined.")
(defvar uncertain-nspecials nil
"Certain explicit actions, such as calls to %SP-BIND, mess up the compiler's
bookkeeping on NSPECIALS. These actions set this flag, which suppresses the
SPECIAL-BINDINGS annotation on return from the function.")
(defvar vars-griped-about nil
"When we gripe about an unknown var being assumed special, put it on this
list so that we don't gripe again while compiling the same function.")
(defvar old-nspecials 0
"The old value of nspecials upon entry to a binding contour.")
(defvar returns-single-value t
"When the compilation of a function is complete, if this is still T, we can
guarantee that the function will return a single value.")
(defvar entry-points nil
"A list of tags, each in format (**TAG** tag), that tell where to
enter the code for various numbers of optional arguments. Built in
reversed order, nreversed before being written out.")
(defvar prefix-code nil
"A list of instructions that must be executed at certain entry points to a
function. Used by CG-Lambda-List and related functions.")
(defvar vars-upstream nil
"A list of variables appearing in the arglist so far. Used by the
lambda-list processing machinery.")
(defvar skip-tag nil
"A tag used to skip around frame-completion code in the the lambda-list
processing machinery.")
(defvar old-venv nil
"Records *VENV* as it was upon entry to a binding contour.")
(defvar inlines nil
"Alist of (function . t-or-nil) indicating whether to expand functions
inline. If not here, of if the expansion is not stored, don't.")
(defvar ignores nil
"List of lexical vars to be ignored by this function. Ignored vars do
not complain if nobody references them.")
(defvar new-specials nil
"Rebound in each binding contour to record which vars are locally declared
special.")
(defvar new-type-decls nil
"Rebound in each binding contour to record local type declarations until
they find their way into the *VENV* entry.")
;;;; MAJOR COMPILER DATA STRUCTURES
;;; ENVIRONMENT FOR VARIABLE BINDINGS.
;;; A variable value can live in one of four places:
;;; SPECIAL values live in the value cell of the symbol, as they have from
;;; time immemorial. Special bindings, setqs, and references are compiled
;;; in pass 1. The only tricky bits are that you have to keep track of how
;;; many specials have been bound, so that when you exit a binding contour
;;; you can peel back the stack to where it belongs. Function returns and
;;; throws do this for free.
;;; Lexical values may be LOCAL if they are bound in the current function
;;; and if nobody references them from a closure. These live on the stack.
;;; But if someone references a local from down in a closure, the binding
;;; function has to cons up a vector, assign the variable a slot in that
;;; vector, and refer to it there. Since you can't tell which case you are
;;; in until after the whole binding-form (including embedded closures) has
;;; been scanned, we put a pseudo op on the the LAP-CODE list in pass 1 and
;;; resolve it into the proper reference type in pass 2.
;;; Finally, if we are compiling a closure and a reference is to a variable
;;; bound not in the current function but in a lexically surrounding
;;; function, we must pick the right value out of the lexical environment
;;; structure. This is a list of the closed variable vectors that come down
;;; from the surrounding function, and its surrounding function, etc. This
;;; "lexical environment object" is the value of the special variable
;;; %lexical-environment% during the execution of a closure. We
;;; CDR down this list according to how many levels of closure we must
;;; cross, and then reference the proper value. This too is resolved in
;;; pass 2.
;;; During compilation we keep track of the visible variable-binding
;;; environemnt using the *VENV* list. THis is an A-list of
;;; (variable-name . structure) pairs, where the structure is a defstruct
;;; giving necessary information an incarantion of a variable. The first
;;; occurrence of a variable on *VENV* is the visible one -- all others are
;;; shadowed. If it is not on *VENV* it might have been proclaimed globally
;;; special. Else, assume it is special, but complain.
;;; For each variable incarnation we need to keep track of the following:
;;;
;;; SPECIALP T if the var is special, NIL if it is lexical.
;;; CLOSURE-INDEX NIL if the var can be local. If it must be consed
;;; into a closure vector, its index in that vector.
;;; FUNCTION-LEVEL The number of levels of FUNCTION between the binding
;;; form and the lexical top level.
;;; USEDP T if a lexical var has been referenced, NIL otherwise.
;;; DECLARED-TYPE Records TYPE declaration for this variable, or NIL if none.
;;; HOME Used to record the index of the variable as a special
;;; or (local <index>) or (arg <index>). If the var turns
;;; into a closed var, its index goes in the closure-index
;;; slot and this slot holds the original home.
(defvar *venv* nil)
(defstruct
(venv
(:constructor
make-venv (specialp function-level)))
specialp
function-level
(closure-index nil)
(usedp nil)
(declared-type nil)
(home nil))
;;; This is used for passing the lexical environment object into a closure
;;; when that closure is called.
(defvar %lexical-environment% nil)
;;; ENVIRONMENT FOR FUNCTION NAMES.
;;; *FENV* is an alist used by FLET, LABELS, and MACROLET to create a lexical
;;; binding environment for functions and macros.
;;; For FLET and LABELS we make up an internal name for each of the functions
;;; and bind it in a LET* to the proper function object. The FENV entry is
;;; of format (external-name . internal-name). Transform replaces any use of
;;; the external name with a funcall to the internal name.
;;; For a MACROLET we get the lambda expression for the expander and
;;; the *FENV* entry is (name . lambda-exp).
(defvar *fenv* nil)
;;; ENVIRONMENT FOR BLOCK/RETURN, TAGBODY/GO.
;;; Block/Return is a tricky business. In general, a block turns into a
;;; catch and the return turns into the corresponding throw. This works,
;;; regardless of levels of closure or intervening garbage on the stack, but
;;; is expensive. We would prefer to just push the return value(s) and go
;;; to the proper tag whenever this is possible, perhaps unbinding some
;;; specials along the way. In particular, we'd better be able to do this
;;; for the cases where old-fashioned PROG/RETURN work.
;;; *BENV* serves a dual role as the a-list of visible block names, with
;;; their associated information structures, and also a model of what's on
;;; the call stack. In addition to block entries there are tagbody entries,
;;; since some tagbodies also turn into catch frames, and GARBAGE markers.
;;; When a RETURN-FROM is encountered, we scan the *BENV* list looking for
;;; the first block-entry with that name. There are now several cases,
;;; listed in decreasing order of priority:
;;; If the function-level of the entry is not the same as that of the
;;; RETURN-FROM, then there must be a throw. Mark the block entry as
;;; being catch-type.
;;; If the block was called to produce a value in tail-recursive position,
;;; the function return will clean up the stack and unbind any specials.
;;; Just go to the tag.
;;; If the target block is already catch-type, or if there is garbage or a
;;; catch-type block or tagbody entry between the return and the target, do
;;; the return as a throw and mark the target as being catch-type.
;;; Else, we be able to just jump out, doing the proper unbinding of
;;; specials, but some later return might mess things up. Put a marker on
;;; LAP-CODE and resolve the issue when the block is exited. Convert the
;;; marker to the proper code in PASS-2. Convert the block entry marker at
;;; that time as well.
;;; An entry on *BENV* is one of (%block name . structure),
;;; (%tagbody taglist . structure), (%garbage), or (%catch-garbage). The
;;; %block entry holds the following information:
;;; END-TAG If you just jump out of the block, this is the tag
;;; to jump to.
;;; FOR-VALUE Return forms need to know whether the block was
;;; called for single or multiple values or TAIL.
;;; FUNCTION-LEVEL If the BLOCK and RETURN do not have the same
;;; function level, there must be a throw.
;;; NSPECIALS Number of specials bound at start of block.
;;; CATCH-TAG If someone does have to throw, make up a tag and
;;; stick it in here. Else, this is NIL.
;;; FIXUPS Some decisions about whether to jump or throw must
;;; be deferred until the block is complete. Every time
;;; we defer a decision about a return to this block, push
;;; the thrower's *BENV* here.
(defvar *benv* nil)
(defun print-benv (foo stream bar)
(declare (ignore foo bar))
(princ "<Block>" stream))
(defstruct
(benv
(:constructor make-benv (end-tag for-value function-level nspecials))
(:print-function print-benv))
end-tag
for-value
function-level
nspecials
(catch-tag nil)
(fixups nil))
;;; The tagbody problem is similar -- in many cases you can just go to the
;;; tag, but in some cases there is unknown garbage or catch frames on the
;;; stack. In the more complex cases, the GO compiles into a throw of some
;;; integer index to a catch header set up at entry to the tagbody. If the
;;; throw occurs, the index is used to dispatch to the right go-tag.
;;; The TENV structure contains the following information:
;;;
;;; FUNCTION-LEVEL
;;; NSPECIALS
;;; NEXT-INDEX Each tag that is thrown to is assigned an index number for
;;; use in the subsequent dispatch. This is the counter for
;;; index-numbe assignments.
;;; CATCH-TAG A catch tag created if anyone needs to do a THROW-type GO.
;;; TAGS A structure for each tag in this body.
;;; FIXUPS Same as for BENV.
(defun print-tenv (foo stream bar)
(declare (ignore foo bar))
(princ "<Tagbody>" stream))
(defstruct (tenv (:constructor make-tenv (function-level nspecials next-index))
(:print-function print-tenv))
function-level
nspecials
next-index
(catch-tag nil)
(tags nil)
(fixups nil))
;;; The TAG structure contains the following information:
;;;
;;; NAME The external name for this tag. May not be unique.
;;; INTERNAL-TAG The unique branch tag to which we want to jump.
;;; INDEX A small integer used to characterize the tag if
;;; anyone needs to do a go the hard way. Else NIL.
;;; USEDP NIL if there is no go to this tag.
(defstruct (tag (:constructor make-tag (name internal-tag)))
name
internal-tag
(index nil)
(usedp nil))
;;;; ERROR REPORTING.
;;; CLC-MUMBLE is just a format print to the error stream.
(defun clc-mumble (string &rest args)
(let ((stream (or *clc-err-stream* *standard-output*)))
(apply #'format stream string args)))
;;; A COMMENT is something the user might like to know, but that will
;;; probably not affect the correctness of his code.
(defun clc-comment (string &rest args)
(let ((stream (or *clc-err-stream* *standard-output*)))
(cond (function-name
(format stream "~%Comment in ~S: " function-name))
(t (format stream "~%Comment between functions: ")))
(terpri stream)
(princ " " stream)
(apply #'format stream string args)))
;;; A WARNING is something suspicious in the user's code that probably
;;; signals some form of lossage, but that may be ignored if the user
;;; knows what he is doing.
(defun clc-warning (string &rest args)
(let ((stream (or *clc-err-stream* *standard-output*)))
(incf warning-count)
(cond (function-name
(format stream "~%Warning in ~S: " function-name))
(t (format stream "~%Warning between functions: ")))
(terpri stream)
(princ " " stream)
(apply #'format stream string args)))
;;; An ERROR is a problem in the user's code that will definitely cause some
;;; lossage. The compiler attempts to go on with the compilation so that
;;; as many errors as possible can be caught per compilation.
(defun clc-error (string &rest args)
(let ((stream (or *clc-err-stream* *standard-output*)))
(incf error-count)
(cond (function-name
(pushnew function-name functions-with-errors)
(format stream "~%Error in ~S: " function-name))
(t (format stream "~%Error between functions: ")))
(terpri stream)
(princ " " stream)
(apply #'format stream string args)))
;;;; GENSYM STUFF.
;;; Gensym-type functions for use in the compiler. All run off a single
;;; global counter.
;;; NEW-INTERNAL-TAG creates a new GO-TAG, unique to this incarnation of
;;; the compiler.
(defvar clc-counter 0
"Counter for the compiler's internal Gensyms.")
(defmacro new-internal-tag ()
'(incf clc-counter))
;;; NEW-INTERNAL-VARIABLE returns a new variable name, unique to this
;;; top-level form. We maintain a free list of these things.
(defvar *free-internal-variables* nil)
(defvar *currently-free-internal-variables* nil)
(defmacro new-internal-variable ()
'(if *currently-free-internal-variables*
(pop *currently-free-internal-variables*)
(really-new-internal-variable)))
(defun really-new-internal-variable ()
(setq clc-counter (1+ clc-counter))
(let ((symbol
(make-symbol (concatenate 'simple-string
"INTERNAL-VARIABLE-"
(princ-to-string clc-counter)))))
(push symbol *free-internal-variables*)
symbol))
;;; BREAKOFF-NAME creates a name for an internal broken-off lambda.
(defun breakoff-name ()
(setq clc-counter (1+ clc-counter))
(make-symbol (concatenate 'simple-string
(symbol-name function-name)
"-INTERNAL-"
(princ-to-string clc-counter))))
;;;; RANDOM STUFF.
;;; INST-OUT macro pushes a new instruction onto LAP-CODE.
(defmacro inst-out (i) `(setq lap-code (cons ,i lap-code)))
;;; MODIFY-PATHNAME-TYPE creates a pathname just like its argument, but
;;; substituting the specified type.
(defun modify-pathname-type (pathname type)
(make-pathname :host (pathname-host pathname)
:device (pathname-device pathname)
:directory (pathname-directory pathname)
:name (pathname-name pathname)
:type type
:version :newest))
;;; MAKE-CONST gets a constant expression C and finds a slot for it in the
;;; constants area. The constant's index is returned. Normally this adds
;;; the new constant to CONSTANTS-LIST and ticks the count, but if an EQUAL
;;; constant already exists, it uses that.
(defun make-const (c)
(do ((cl constants-list (cdr cl))
(i (1- nconstants) (1- i)))
((null cl)
(push c constants-list)
(setq nconstants (1+ nconstants))
(1- nconstants))
(if (equal c (car cl)) (return i))))
;;; Get-Local is a macro that returns the index for the next local to be
;;; used, updating Next-Local and Nlocals as appropriate.
(defmacro get-local ()
'(prog1 next-local
(setq next-local (1+ next-local))
(and (> next-local nlocals)
(setq nlocals (1+ nlocals)))))
;;; Get-Closure-Index is passed a *VENV* for a variable that is to be
;;; referenced as a closure. If that entry already has an index in the
;;; Venv-Closure-Index slot, just return that index. Else, an index
;;; must be assigned. Crawl back the right number of levels on the
;;; Closure-Var-Count-List and tick the number by one, returning the old
;;; count as the index.
(defun get-closure-index (entry)
(or (venv-closure-index (cdr entry))
(let* ((level (- function-level (venv-function-level (cdr entry))))
(slot (nthcdr level closed-var-count-list))
(n (car slot)))
(rplaca slot (1+ n))
(setf (venv-closure-index (cdr entry)) n))))
;;; TEST-VARNAME is passed an atom alleged to be a variable name. It
;;; tests for a number of illegal conditions and issues error or warning
;;; messages if these are seen. Returns NIL if there is no way to proceed,
;;; else returns T.
(defun test-varname (var)
(cond ((not (symbolp var))
(clc-error "~S -- variable name must be a symbol." var) nil)
((or (get var 'constant-in-compiler)
(get var '%constant)
(memq var '(t nil)))
(clc-error "~S is a constant -- cannot bind or set it." var) nil)
(t t)))
;;; Given a symbol X, determine whether a reference to that symbol would be a
;;; lexical reference in the current context. Be careful using this for init
;;; expressions in a binding form, as these might be altered by special
;;; declarations down in the body.
(defmacro lexical-reference-p (x)
`(let ((temp (assq ,x *venv*)))
(and temp (not (venv-specialp (cdr temp))))))
(defmacro special-reference-p (name)
`(let ((x ,name))
(or (get x 'globally-special)
(let ((venv (cdr (assoc x *venv*))))
(and venv (venv-specialp venv))))))
;;; Check whether X is a constant or some other "trivial" expression.
;;; "Trivial" means no side-effects and cheaper to recompute than to save.
;;; Used in macros and transforms where one arg is going to be used in
;;; two places: if arg expression is trivial, it is OK to compute it twice.
;;; If not, must compute it only once and save the result for multiple uses.
;;; Use only in contexts that do not themselves clobber X.
(defun trivialp (x)
(or (and (symbolp x) (lexical-reference-p x))
(constantp x)
(and (listp x)
(eq (car x) 'the)
(trivialp (caddr x)))))
;;; This is like trivialp, but allows any variables, not just locals.
(defun trivial*p (x)
(or (symbolp x)
(constantp x)
(and (listp x)
(eq (car x) 'the)
(trivial*p (caddr x)))))
;;; This accepts things which are composed of trivial and side effect free
;;; expressions.
(defun side-effect-free-p (form)
(or (trivial*p form)
(and (listp form)
(get (car form) 'expr-with-no-side-effects)
(dolist (sub-form (cdr form) t)
(if (not (side-effect-free-p sub-form)) (return nil))))))
;;; This function returns T if it can guarantee that FORM contains no
;;; references to VAR. Assumes VAR is lexical.
;;; Note that also fails if the variable is set, since that might cause
;;; some sets to get done different orders in cg-psetq.
(defun contains-no-reference-to (form var)
(or (constantp form)
(multiple-value-bind (s r) (sf-analyze-list (list form) (list var))
(not (or s r)))))
;;; Various things such as tail-recursion elimination need to check whether
;;; there is garbage (catch frames, arguments to a not-yet-activated function,
;;; etc.) on the stack. This does the checking.
(defmacro no-garbage-on-stack-p (benv)
`(dolist (x ,benv t)
(if (or (eq (car x) '%garbage) (benv-catch-tag (cddr x))) (return ()))
(if (eq (cadr x) function-name) (return t))))
;;; Once-Only returns a piece of code in which the body is evaluated with each
;;; of the variables in Var-List bound to the corresponding form iff the form
;;; is non-trivial. This is mainly of use in writing transforms and such.
;;;
;;; A typical use looks like:
;;;
;;; (deftransform foo foo-transform (a b c)
;;; (once-only ((a-name a) (b-name b))
;;; `(bar ,a-name ,b-name ,c ,a-name ,b-name)))
;;;
;;; <=>
;;;
;;; (deftransform foo foo-transform (a b c)
;;; (let ((a-name (if (trivialp a) a (new-internal-variable)))
;;; (b-name (if (trivialp b) b (new-internal-variable))))
;;; `(let (,@(unless (eq a a-name) `((,a-name ,a)))
;;; ,@(unless (eq b b-name) `((,b-name ,b))))
;;; `(bar ,a-name ,b-name ,c ,a-name ,b-name))))
(defmacro once-only (var-list &rest body)
(do ((var-list var-list (cdr var-list))
(name-bindings ())
(variable-bindings ()))
((null var-list)
`(let ,(nreverse name-bindings)
(list 'let (nconc ,@(nreverse variable-bindings)) ,@body)))
(let ((var-name (caar var-list))
(var (cadar var-list)))
(push `(,var-name (if (trivialp ,var) ,var (new-internal-variable)))
name-bindings)
(push `(if (not (eq ,var-name ,var)) (list (list ,var-name ,var)))
variable-bindings))))
;;;; FUNCTIONS FOR BUILDING THE COMPILER ENVIRONMENT.
;;; DEFTRANSFORM is like DEFMACRO, but adds the expander function to
;;; a list kept under the function's TRANSFORMS property. There can be
;;; many transforms for a given function, and they are applied until the
;;; form is changed into something without transforms or until all of the
;;; transforms pass. If a transform does not want to change a function,
;;; it should return the marker %PASS%.
(defmacro deftransform (fn name arglist &body body)
(let ((local-decs nil)
(%arg-count 0)
(%min-args 0)
(%restp nil)
(%let-list nil)
(%keyword-tests nil))
(declare (special %arg-count %min-args %restp %let-list %keyword-tests))
;; Check for local declarations and documentation string.
(prog ()
LOOP
(cond ((atom body)
(setq body '(nil)))
((and (not (atom (car body))) (eq (caar body) 'declare))
(setq local-decs (append local-decs (cdar body)))
(setq body (cdr body))
(go loop))
((and (stringp (car body)) (not (null (cdr body))))
(setq body (cdr body))
(go loop))))
;; Analyze the defmacro argument list.
(let ((*key-finder* 'find-keyword-in-transform))
(declare (special *key-finder*))
(analyze1 arglist '(cdr **form**) fn '**form**))
;; Now build the body of the transform.
(when (null arglist) (push '(ignore **form**) local-decs))
(setq body `(let* ,(nreverse %let-list)
,@ (and local-decs (list (cons 'declare local-decs)))
,@ %keyword-tests
,@ body))
`(progn
(note-args ',fn ,%min-args ,%arg-count ,%restp)
(defun ,name (**form**) ,body)
(%put ',fn 'clc-transforms (cons ',name (get ',fn 'clc-transforms))))))
;;; Use this special keyword tester in transforms to properly digest
;;; quoted keywords.
(defun find-keyword-in-transform (keyword keylist)
"If keyword is present in the keylist, return a list of its argument.
Else, return NIL."
(do ((l keylist (cddr l)))
((atom l) nil)
(cond ((atom (cdr l))
(cerror "Stick a NIL on the end and go on."
"Unpaired item in keyword portion of macro call.")
(rplacd l (list nil))
(return nil))
((eq (car l) keyword) (return (list (cadr l))))
((and (consp (car l)) (eq (caar l) 'quote)
(consp (cdar l)) (eq (cadar l) keyword))
(return (list (cadr l))))
((not (constantp (car l)))
;; Some turkey is passing in a hairy expression as a keyword.
;; Pass on this transform, and gripe if the user wants that.
(when *complain-about-inefficiency*
(clc-comment
"Keyword not constant at compile time -- cannot open code."))
(throw 'pass-catcher '%pass%)))))
;;; Defsynonym declares NEW to be a synonym for OLD. Both must be symbols
;;; appearing the function position of a form.
(defmacro defsynonym (new old)
`(%put ',new 'synonym ',old))
;;; Defprimitive declares PRIMITIVE to be a primitive operation that implements
;;; the given FUNCTION.
(defmacro defprimitive (function primitive)
`(%put ',function 'primitive-operation ',primitive))
;;; DEF-CG creates a macro-like code-generator for the specified form.
;;; There is only one CG form per function or special form.
(defmacro def-cg (fn name arglist &body body)
(let ((%arg-count 0)
(%min-args 0)
(%restp nil)
(%let-list nil)
(%keyword-tests nil))
(declare (special %arg-count %min-args %restp %let-list %keyword-tests))
;; Analyze the defmacro argument list.
(analyze1 arglist '(cdr **form**) fn '**form**)
;; Now build the body of the CG form.
(setq body `(let* ,(nreverse %let-list) ,@body))
`(progn
(defun ,name (**form**)
,@(if (null arglist) '((declare (ignore **form**))) nil)
,body)
(%put ',fn 'cg ',name))))
;;; DEF-P2 creates a macro-like pass-2 processor for the specified
;;; pseudo-op.
(defmacro def-p2 (fn name arglist &body body)
(let ((%arg-count 0)
(%min-args 0)
(%restp nil)
(%let-list nil)
(%keyword-tests nil))
(declare (special %arg-count %min-args %restp %let-list %keyword-tests))
;; Analyze the defmacro argument list.
(analyze1 arglist '(cdr **form**) fn '**form**)
;; Now build the body of the P2 form.
(setq body `(let* ,(nreverse %let-list) ,@body))
`(progn
(defun ,name (**form**)
,@(if (null arglist) '((declare (ignore **form**))) nil)
,body)
(%put ',fn 'p2 ',name))))
;;;; BOOKKEEPING.
;;; ASSUME-EXPR is used when we encounter a function not yet declared or
;;; defined. We record the lowest and highest numbers of args that the
;;; function has been called with, so that when we finally see the function
;;; we can at least warn that someone has lost.
;;; The ASSUMED-EXPR property holds ( <min args seen> . <max args seen> )
(defun assume-expr (name arg-count)
(pushnew name unknown-functions)
(let ((counts (get name 'assumed-expr)))
(cond (counts
(if (< arg-count (car counts))
(rplaca counts arg-count))
(if (> arg-count (cdr counts))
(rplacd counts arg-count)))
(t (setf (get name 'assumed-expr)
(cons arg-count arg-count))))))
;;; NOTE-TYPE is used to record the type of a function (Expr, Fexpr, or
;;; Macro) under the Declared-Function-Type property.
(defun note-type (fn type)
(let ((old-type (get-declared-function-type fn)))
(if (and old-type (not (eq type old-type)))
(clc-warning "Type of ~S being changed from ~S to ~S."
fn old-type type))
(if (and (not (eq type 'expr)) (get fn 'assumed-expr))
(clc-warning "~S earlier assumed to be a normal function." fn))
(setf (get fn 'declared-function-type) type)))
;;; Add new arg count to function, but complain if it doesn't match a
;;; pre-existing count. The count goes under the CLC-ARGS property
;;; in format (min . max) or just (min) if there is no upper limit.
(defun note-args (fn min-allowed max-allowed restp)
(let ((old (get-function-arg-counts fn))
(assumed (get fn 'assumed-expr))
(argcount (if restp
(list min-allowed)
(cons min-allowed max-allowed))))
(cond ((not assumed))
((< (car assumed) min-allowed)
(clc-warning "~S earlier called with ~S args, wants at least ~S."
fn (car assumed) min-allowed))
((and (not restp) (> (cdr assumed) max-allowed))
(clc-warning "~S earlier called with ~S args, wants at most ~S."
fn (cdr assumed) max-allowed)))
(remprop fn 'assumed-expr)
(cond ((null old)
(setf (get fn 'clc-args) argcount))
((and (eql (car argcount) (car old))
(eql (cdr argcount) (cdr old))))
(t (clc-warning
"New definition for ~S changing arg count from ~S to ~S."
fn old argcount)
(setf (get fn 'clc-args) argcount)))))
;;;; PARSING ROUTINES
;;; These parse certain complicated forms into more digestible chunks.
;;; PARSE-BODY1 takes the body of a defun-like form (everything after the
;;; varlist) and takes it apart. Returns a list of three elements: all the
;;; declarations, in order, then the documentation string, if any, then
;;; the rest of the body. Macros that may be declarations are expanded
;;; and looked at, but are returned unexpanded.
;;; This is not quite the same as the PARSE-BODY that lives in EVAL.
(defun parse-body1 (body)
(do ((b body (cdr b))
(decls nil)
(doc nil)
(temp nil))
((null b) (list (nreverse decls) doc nil))
(cond ((and (stringp (car b)) (cdr b) (null doc))
(setq doc (car b)))
((not (listp (setq temp (transform (car b)))))
(return (list (nreverse decls) doc b)))
((eq (car temp) 'declare)
(dolist (x (cdr temp)) (push x decls)))
(t (return (list (nreverse decls) doc b))))))
;;; Parse-Body2 is the same as Parse-Body1, but works in contexts where no
;;; doc string is allowed. Returns a list of two elements: all the
;;; declarations, in order, then the rest of the body. Macros that may be
;;; declarations are expanded and looked at, but are returned unexpanded.
(defun parse-body2 (body)
(do ((b body (cdr b))
(decls nil)
(temp nil))
((null b) (list (nreverse decls) nil))
(cond ((not (listp (setq temp (transform (car b)))))
(return (list (nreverse decls) b)))
((eq (car temp) 'declare)
(dolist (x (cdr temp)) (push x decls)))
(t (return (list (nreverse decls) b))))))
;;;; TYPE DETERMINATION
;;; FIND-TYPE returns a type-specifier that indicates the type of object
;;; that will be produced by evaluating FORM. If this cannot be determined,
;;; returns T. For symbols, look for a declaration. For constants, return
;;; the type. For function calls, use the Result-Type and Result-Function
;;; properties set up by the FNDEFS file.
;;; Always returns a symbol, never a list-type specifier.
(defun find-type (form)
(let ((type
(cond ((symbolp form)
(let (temp)
(cond ((null form)
;; NIL is also a Symbol, but List is more useful.
'list)
((eq form t) 'symbol)
((keywordp form) 'symbol)
((setq temp (assq form *venv*))
(or (venv-declared-type (cdr temp)) t))
((get form 'globally-special-type))
(t t))))
((or (numberp form)
(characterp form)
(stringp form)
(bit-vector-p form))
(type-of form))
((listp form)
(cond ((eq (car form) 'quote)
(type-of (cadr form)))
((eq (car form) 'the)
(cadr form))
(t (let (temp)
(cond ((not (symbolp (car form))) t)
((setq temp (get (car form) 'result-function))
(funcall temp (cdr form)))
((setq temp (get (car form) 'result-type))
temp)
(t t))))))
(t t))))
(when (consp type) (setq type (car type)))
(when (and *all-integers-are-fixnums* (eq type 'integer))
(setq type 'fixnum))
type))
;;; Numeric-result-type does numeric contagion over all the arguments.
(defun numeric-result-type (args)
(do ((a args (cdr a))
(winner 'fixnum)
temp)
((atom a) winner)
(setq temp (find-type (car a)))
(cond ((or (eq temp 'number)
(not (subtypep temp 'number)))
(return 'number))
(t (setq winner (number-type-max winner temp))))))
;;; This does contagion for things like 1+ and 1-.
(defun numeric-result-type1 (args)
(let ((argtype (find-type (car args))))
(cond ((or (eq argtype 'number)
(not (subtypep argtype 'number)))
'number)
(t (number-type-max 'integer argtype)))))
;;; This does contagion for /.
(defun /-result-type (args)
(let ((temp (numeric-result-type args)))
(if (subtypep temp 'integer)
'rational
temp)))
;;; This function establishes the pecking order for number-type contagion
;;; within arithmetic functions. Given two args, returns the type of
;;; the result. Args are symbols that are subtypep of number, but not number
;;; itself.
;;; Note: given two fixnums, return integer, since there might be an overflow,
;;; unless the *all-integers-are-fixnums* switch is on.
(defun number-type-max (x y)
(dolist (z '(long-float double-float single-float short-float ratio
integer bignum fixnum)
'number)
(cond ((not (or (eq x z) (eq y z))))
((and (eq z 'fixnum) (not *all-integers-are-fixnums*))
(return 'integer))
((eq z 'bignum) (return 'integer))
(t (return z)))))
;;; Boolean-result-type returns FIXNUM if all the args are fixnums, else
;;; returns INTEGER.
(defun boolean-result-type (args)
(if *all-integers-are-fixnums*
'fixnum
(do ((a args (cdr a)))
((atom a) 'fixnum)
(unless (subtypep (find-type (car a)) 'fixnum)
(return 'integer)))))
;;; Convert-byte-spec takes an expression that represents a byte specifier
;;; and sees if it is a compile-time constant of the form (integer . integer)
;;; or a call to BYTE with two explicit integers. If so, returns the dotted
;;; pair, else returns NIL.
(defun convert-byte-spec (form)
(when (and (symbolp form)
(get form 'constant-in-compiler))
(setq form (get form 'constant-value)))
(cond ((constantp form)
(eval form))
((and (consp form)
(eq (car form) 'byte)
(integerp (cadr form))
(integerp (caddr form)))
(cons (cadr form) (caddr form)))
(t nil)))
;;;; TOP-LEVEL STUFF
;;; Compile-File is the major entry point for the compiler.
;;; If any of :OUTPUT-FILE, :ERROR-FILE, or :LAP-FILE
;;; are specified and non-null, use the name supplied. A value of
;;; T means construct a name by adding the proper type to the input
;;; file's truename. A value of NIL means don't generate that kind
;;; of output. :OUTPUT-FILE and :ERROR-FILE default to T, the others
;;; to NIL.
(defun compile-file
(&optional input-pathname
&key (output-file t)
(error-file t)
(lap-file nil)
(errors-to-terminal t)
(load nil))
"Compiles the file identified by the Input-Pathname, producing a
corresponding .SFASL file. Other options available via keywords."
(let ((unknown-functions nil)
(unknown-free-vars nil)
(functions-with-errors nil)
(error-count 0)
(warning-count 0)
(input-namestring nil)
(original-input-pathname nil)
(error-file-stream nil)
(*clc-input-stream* nil)
(*clc-fasl-stream* nil)
(*clc-err-stream* nil)
(*clc-lap-stream* nil)
(*random-top-level-forms* nil)
(*package* *package*)
(*in-the-compiler* t)
(compile-won nil))
(unwind-protect
(progn
(unless input-pathname
(format t "~%File to compile, as a string: ")
(setq input-pathname (read)))
;; Make sure the specified input file exists.
(tagbody
LOOP
(setq original-input-pathname input-pathname)
(setq input-pathname (pathname input-pathname))
(unless (pathname-type input-pathname)
(setq input-pathname
(modify-pathname-type input-pathname "slisp")))
(unless (setq input-pathname (truename input-pathname))
(cerror "Prompt for new file name."
"Input file does not exist: ~S"
(namestring original-input-pathname))
(format t "~%Corrected file name, as a string: ")
(setq input-pathname (read))
(go loop)))
;; Note the truename of the input file.
(setq input-namestring (namestring input-pathname))
;; Open the input stream.
(setq *clc-input-stream*
(open input-pathname
:direction :input))
;; Set up the output stream.
(cond ((null output-file))
(t (setq *clc-fasl-stream*
(open
(if (eq output-file t)
(setq output-file
(modify-pathname-type input-pathname "sfasl"))
output-file)
:direction :output
:element-type '(unsigned-byte 8)))
(init-fasl-file)))
;; Set up the lap stream.
(cond ((null lap-file))
(t (setq *clc-lap-stream*
(open (if (eq lap-file t)
(modify-pathname-type input-pathname "slap")
lap-file)
:direction :output))
(print-file-header *clc-lap-stream* "Lap" input-namestring)))
;; Set up the error stream.
(cond ((null error-file))
(t (setq error-file-stream
(open (if (eq error-file t)
(modify-pathname-type input-pathname "err")
error-file)
:direction :output))
(print-file-header error-file-stream "Error"
input-namestring)
(setq *clc-err-stream*
(if errors-to-terminal
(make-broadcast-stream *standard-output*
error-file-stream)
error-file-stream))))
;; All set up. Let the festivities begin.
(clc-mumble "~%Starting compilation of file ~S.~%" input-namestring)
(readloop)
(process-outstanding-random-forms)
;; All done. Let the post-mortems begin.
(clc-mumble "~2%Finished compilation of file ~S." input-namestring)
(clc-mumble "~%~S Errors, ~S Warnings." error-count warning-count)
(when functions-with-errors
(clc-mumble
"~%Errors were detected in the following functions:~%~S"
(nreverse functions-with-errors)))
(when unknown-functions
(clc-mumble
"~&The following functions, assumed to be functions, are referenced~@
but not declared or defined: ~%~S"
(nreverse unknown-functions)))
(when unknown-free-vars
(clc-mumble
"~&The following variables, assumed to be special, are referenced~@
free but never declared: ~%~S"
(nreverse unknown-free-vars)))
(terpri)
(setq compile-won t))
;; Close files. Unwind-protect makes sure that these get closed even
;; if compilation is aborted. If the compile did not win, abort the fasl
;; file instead of writing out a whole lot of useless stuff.
(when (streamp *clc-input-stream*) (close *clc-input-stream*))
(when (streamp *clc-fasl-stream*)
(terminate-fasl-file)
(close *clc-fasl-stream* :abort (not compile-won)))
(when (streamp error-file-stream) (close error-file-stream))
(when (streamp *clc-lap-stream*) (close *clc-lap-stream*)))
(when load
(format t "~&Loading compiled file: ~S"
(namestring (truename output-file)))
(load output-file))))
;;; PRINT-FILE-HEADER prints assorted information at the start of an
;;; ascii output file.
(defun print-file-header (stream output-type input-namestring)
(format stream
"~%;;; ~A output for file ~A."
output-type input-namestring)
(format stream
"~%;;; Compiled by compiler version ~A, assembler version ~A.~%"
compiler-version assembler-version))
;;; READLOOP reads objects from the input file one by one and passes each
;;; to process-form for analysis and possible compilation.
(defvar eof-value '(nil)
"A unique consed object that can be recognized as the end-of-file signal.")
(defun readloop ()
(do ((form (read *clc-input-stream* nil eof-value)
(read *clc-input-stream* nil eof-value)))
((eq form eof-value))
(let ((*currently-free-internal-variables* *free-internal-variables*))
(process-form form))))
(defun compile-from-stream (*clc-input-stream*)
"Read input from stream until end of file is encountered, compiling this
input into the current environment."
(let* ((*compile-to-lisp* t)
(unknown-functions nil)
(unknown-free-vars nil)
(*function-definitions-to-set-up* nil)
(functions-with-errors nil)
(error-count 0)
(warning-count 0)
(*random-top-level-forms* nil)
(*package* *package*)
(*in-the-compiler* t)
(compile-won nil))
(unwind-protect
(progn
(readloop)
(process-outstanding-random-forms)
(clc-mumble "~%~S Errors, ~S Warnings." error-count warning-count)
(when functions-with-errors
(clc-mumble
"~%Errors were detected in the following functions:~%~S"
(nreverse functions-with-errors)))
(when unknown-functions
(clc-mumble
"~&The following functions, assumed to be functions, are referenced~@
but not declared or defined: ~%~S"
(nreverse unknown-functions)))
(when unknown-free-vars
(clc-mumble
"~&The following variables, assumed to be special, are referenced~@
free but never declared: ~%~S"
(nreverse unknown-free-vars)))
(terpri)
(setq compile-won t))
(when compile-won
(dolist (x (nreverse *function-definitions-to-set-up*))
(setf (symbol-function (car x)) (cdr x))
(if (eq (car x) '|Random Top-Level Form|) (funcall (car x))))))))
;;; COMPILE is the entry point for compiling a single function with a
;;; running Lisp.
(defun compile (name &optional (definition nil definition-p))
"Compiles the function whose name is Name. If Definition is supplied,
it should be a lambda expression that is compiled and then placed in the
function cell of Name. If Name is Nil, the compiled code object is
returned."
(let* ((old-definition (or definition (symbol-function name)))
(function old-definition)
(function-type 'expr)
(function-name (or name '|Anonymous lambda|))
(*compile-to-lisp* t)
(*currently-free-internal-variables* *free-internal-variables*))
(cond ((compiled-function-p function)
(error "~S already compiled." function-name))
((atom function)
(error "~S has illegal definition." function-name))
((eq (car function) '%lexical-closure%)
(error "~S is a lexical closure. Cannot compile it alone."
function-name))
((eq (car function) 'macro)
(setq function-type 'macro)
(setq function (cdr function)))
((eq (car function) 'fexpr)
(setq function-type 'fexpr)
(setq function (cdr function))))
(unless (and (consp function) (eq (car function) 'lambda))
(error "~S has illegal definition." function-name))
(let* ((unknown-functions nil)
(unknown-free-vars nil)
(functions-with-errors nil)
(error-count 0)
(warning-count 0)
(*clc-input-stream* nil)
(*clc-fasl-stream* nil)
(*clc-lap-stream* nil)
(*clc-err-stream* *standard-output*)
(*venv* nil)
(*fenv* nil)
(*benv* nil)
(*in-the-compiler* t)
(function-object (compile-one-lambda function)))
(cond ((= error-count 0)
(cond (name (setf (symbol-function name)
(if (eq function-type 'macro)
(cons 'macro function-object)
function-object))
(if (not definition-p)
(setf (get name 'previous-definition)
old-definition))
t)
(t function-object)))
(t nil)))))
(defun uncompile (name)
"Restores the previous interpreted definition of the function
named by NAME, if it can find one."
(when (and (compiledp name)
(get name 'previous-definition))
(setf (symbol-function name) (get name 'previous-definition))
(remprop name 'previous-definition)
name))
(defun internal-compiledp (func)
(cond ((compiled-function-p func) t)
((consp func)
(cond ((eq (car func) 'MACRO)
(compiled-function-p (cdr func)))
((eq (car func) '%COMPILED-CLOSURE%) t)))
(t nil)))
(defun compiledp (x)
"Predicate that is true if the argument is a compiled-function or if
it names one."
(or (internal-compiledp x)
(and (symbolp x)
(fboundp x)
(internal-compiledp (symbol-function x)))))
;;;; FORM PROCESSING
;;; PROCESS-FORM takes one Lisp object from the input file (or wherever),
;;; transforms it (expanding any top-level macros or transforms), and then
;;; does the appropriate top-level compiler-thing to it. If the form is not
;;; a random form, we flush the outstanding random forms before touching it.
(defun process-form (form)
(setq form (transform form t))
(if (atom form)
nil
(case (car form)
(defun
(process-outstanding-random-forms)
(process-defun form))
(macro
(process-outstanding-random-forms)
(process-macro form))
(progn
(dolist (x (cdr form))
(process-form x)))
(proclaim
(process-proclamation (cadr form)))
;; *** Temporary kludge till everything uses Proclaim. ***
(declare
(clc-warning "Beware: Top-level DECLARE will soon be flushed.")
(dolist (x (cdr form))
(process-proclamation (list 'quote x))))
;; *** End of kludge. ***
(eval-when (process-eval-when form))
(defconstant (process-defconstant form))
(comment nil)
;; When seen at top level, these functions take effect in the
;; compiler's environment, as well as being dumped.
((make-package in-package shadow shadowing-import export
unexport use-package unuse-package import)
(when *eval-when-load*
(fasl-dump-form form))
(eval form))
(t (process-random form)))))
;;; Process-Eval-When -- just bind the global eval-when switches to the
;;; proper values and process the sub-forms.
(defun process-eval-when (form)
(cond ((or (atom (cadr form))
(eq 'quote (caadr form)))
(clc-error "Ill-formed EVAL-WHEN. Ignoring its contents.")
nil)
(t (let ((*eval-when-compile* (memq 'compile (cadr form)))
(*eval-when-load* (memq 'load (cadr form))))
(dolist (x (cddr form))
(process-form x))))))
;;; Process-Defconstant does the proper stuff when a defconstant is
;;; seen at top level. If it is seen when not at top-level, no substitution
;;; for this constant will occur.
(defun process-defconstant (form)
(let* ((var (cadr form))
(val (caddr form))
(docp (cdddr form))
(doc (cadddr form)))
(process-form
`(progn
(proclaim '(special ,var))
(remprop ',var '%constant)
(cond ((boundp ',var)
(unless (equalp (symbol-value ',var) ,val)
(cerror "Go ahead and change the value."
"Constant ~S is being redefined." ',var)
(set ',var ,val)))
(t (set ',var ,val)))
(%put ',var '%constant t)
,@(cond (docp `((%put ',var '%var-documentation ',doc)))
(t nil))))
(%put var 'constant-in-compiler t)
(%put var 'constant-value val)))
;;; Process-Random handles random top-level forms. Consecutive random top-level
;;; forms are accumulated in the list *Random-Top-Level-Forms*. The forms in this
;;; list are then compiled as forms in a function when the next non-random thing
;;; or EOF is encountered.
(defun process-random (form)
(when *eval-when-compile*
(eval form))
(when *eval-when-load*
(push form *random-top-level-forms*)
(if *clc-lap-stream*
(print form *clc-lap-stream*))))
;;; Process-Outstanding-Random-Forms compiles the forms in the list of
;;; *Random-Top-Level-Forms* as a single function.
(defun process-outstanding-random-forms ()
(when *random-top-level-forms*
(let ((function-name '|Random Top-Level Form|)
(function-type 'one-shot)
(function `(lambda () ,@(nreverse *random-top-level-forms*)))
(*verbose* nil))
(compile-one-lambda function))
(setq *random-top-level-forms* nil)))
;;; Macros are always added to the compiler environment as a macro-in-compiler
;;; property. If *Eval-When-Compile* is on, add it to the surrounding Lisp.
;;; If *Eval-When-Load* is on, compile the macro and dump it to the output
;;; file.
(defun process-macro (form)
(cond ((and (symbolp (cadr form))
(not (keywordp (cadr form))))
(%put (cadr form) 'macro-in-compiler (cons 'lambda (cddr form)))
(when *eval-when-compile*
(eval form))
(when *eval-when-load*
(let* ((function (cons 'lambda (cddr form)))
(function-type 'macro)
(function-name (cadr form)))
(compile-one-lambda function))))
(t (clc-error "~S not a legal macro name." (cadr form)))))
;;; If *Eval-When-Compiler* is on, Process-Defun adds a definition to the
;;; compiler. If *Eval-When-Load* is true, the definition is compiled into
;;; the output file.
;;; For bootstrapping purposes, accept the following syntax to define a FEXPR:
;;; (DEFUN name FEXPR arglist . body)
(defun process-defun (form)
(let ((function-name (cadr form)))
(cond ((and (symbolp function-name)
(not (keywordp function-name)))
(when (get function-name 'inline-expansion)
(%put function-name
'inline-expansion
(cons 'lambda (cddr form))))
(remprop function-name 'macro-in-compiler)
(when *eval-when-compile*
(eval form))
(when *eval-when-load*
(if (eq (caddr form) 'fexpr)
(let ((function (cons 'lambda (cdddr form)))
(function-type 'fexpr))
(compile-one-lambda function))
(let ((function (cons 'lambda (cddr form)))
(function-type 'expr))
(compile-one-lambda function)))))
(t (clc-error "~S not a legal function name." function-name)))))
;;;; DECLARATION HACKERY
;;; Process-proclamation is called by Process-Form at top level of compiler.
(defun process-proclamation (form)
(setq form (eval form))
(cond ((not (consp form))
(clc-warning "Illegal form in proclaim, ignoring it: ~S" form))
(t (case (car form)
(special
(dolist (x (cdr form))
(%put x 'globally-special-in-compiler t)
(process-random `(%put ',x 'globally-special t))))
(ftype nil)
(function nil)
(inline
(dolist (x (cdr form))
(cond ((symbolp x)
(push (cons x t) inlines)
(unless (get x 'inline-expansion)
(%put x 'inline-expansion t)))
(t
(clc-error "~S is a bad function name." x)))))
(notinline
(dolist (x (cdr form))
(if (symbolp x)
(push (cons x nil) inlines)
(clc-error "~S is a bad function name." x))))
(optimize (process-optimize-declaration form))
(declaration
(dolist (x (cdr form))
(%put x 'recognized-declaration t)))
(t (let ((x (car form)))
(if (get x 'recognized-declaration)
nil
(clc-warning
"~S unknown proclamation type." x))))))))
;;; When we see a new Optimize declaration, we may alter a bunch of policy
;;; switches. If the scope of the declaration is to be local, bind all
;;; of these.
(defun process-optimize-declaration (form)
(dolist (f (cdr form))
(cond ((atom f)
(case f
(speed (setq optimize-speed 3))
(space (setq optimize-space 3))
(safety (setq optimize-safety 3))
(compilation-speed (setq optimize-cspeed 3))
(t (clc-warning
"~S unknown option to optimize declaration." f))))
((and (consp (cdr f))
(integerp (cadr f))
(>= 0 (cadr f) 3))
(case (car f)
(speed (setq optimize-speed (cadr f)))
(space (setq optimize-space (cadr f)))
(safety (setq optimize-safety (cadr f)))
(compilation-speed (setq optimize-cspeed (cadr f)))
(t (clc-warning
"~S unknown option to optimize declaration." (cadr f)))))
(t (clc-warning
"Ill-formed entry in optimize declaration: ~S" f))))
(setq *peep-enable* (or (>= optimize-space optimize-cspeed)
(>= optimize-speed optimize-cspeed)))
(setq *inline-enable* (>= optimize-speed optimize-space))
(setq *open-code-sequence-functions* (>= optimize-speed optimize-space))
(setq *eliminate-tail-recursion* (> optimize-speed optimize-space))
(setq *array-bounds-check-enable* (< optimize-safety 1))
(setq *cdr-check-enable* (< optimize-safety 1)))
;;; Binding-contour binds a bunch of specials and then processes a
;;; list of declarations. The prevasive declarations change the environment
;;; by altering these specials. Then the body is processed.
(defmacro binding-contour (declarations &body body)
`(let ((optimize-speed optimize-speed)
(optimize-space optimize-space)
(optimize-safety optimize-safety)
(optimize-cspeed optimize-cspeed)
(*peep-enable* *peep-enable*)
(*inline-enable* *inline-enable*)
(*open-code-sequence-functions* *open-code-sequence-functions*)
(*eliminate-tail-recursion* *eliminate-tail-recursion*)
(*array-bounds-check-enable* *array-bounds-check-enable*)
(*cdr-check-enable* *cdr-check-enable*)
(inlines inlines)
(ignores nil)
(new-type-decls nil)
(new-specials nil)
(old-venv *venv*)
(*venv* *venv*)
(old-nspecials nspecials)
(nspecials nspecials)
(next-local next-local))
(process-declarations ,declarations)
,@body))
;;; Process declarations at the start of a binding contour.
(defun process-declarations (dlist)
(dolist (d dlist)
(cond ((not (consp d))
(clc-warning "Illegal form in Declare, ignoring it: ~S" d))
(t (case (car d)
(special
(dolist (x (cdr d))
(test-varname x)
(push x new-specials)
(let ((temp (make-venv t function-level)))
(setf (venv-home temp) (make-const x))
(push (cons x temp) *venv*))
(setq unknown-free-vars
(delq x unknown-free-vars))))
(type
(let ((type (cadr d)))
(dolist (x (cddr d))
(test-varname x)
(push (cons x type) new-type-decls))))
(ftype nil)
(function nil)
(inline
(dolist (x (cdr d))
(test-varname x)
(push (cons x t) inlines)
(unless (get x 'inline-expansion)
(%put x 'inline-expansion t))))
(notinline
(dolist (x (cdr d))
(test-varname x)
(push (cons x nil) inlines)))
(ignore
(dolist (x (cdr d))
(test-varname x)
(push x ignores)))
(optimize (process-optimize-declaration d))
(declaration
(dolist (x (cdr d))
(%put x 'recognized-declaration t)))
(t (let ((x (car d)))
(cond ((memq x type-names)
(dolist (y (cdr d))
(test-varname y)
(push (cons y x) new-type-decls)))
((get x 'recognized-declaration))
(t (clc-warning
"~S unknown declaration type." x))))))))))
;;; Complain about any unreferenced locals. Call only within a binding
;;; contour.
(defun check-used ()
(do ((x *venv* (cdr x)))
((eq x old-venv))
(cond ((venv-usedp (cdar x)))
((venv-specialp (cdar x)))
((memq (caar x) ignores))
(t (clc-warning "~S bound but not referenced." (caar x))))))
;;;; COMPILE-ONE-LAMBDA
;;; Compile-One-Lambda compiles one lambda, does post-processing and
;;; peephole optimization, then passes the code off to be assembled and
;;; dumped, depending on what kind of output is to be produced. If
;;; *compile-to-lisp* or return-code-object is on, returns the compiled
;;; function object, else returns NIL.
;;; If there are embedded #'(lambda ...) calls, these result in recursive
;;; calls to COMPILE-ONE-LAMBDA.
(defun compile-one-lambda (form)
(let* ((lap-code (list (new-internal-tag) '(code-start)))
(lap-code-start lap-code)
(lap-function nil)
(function-object nil)
(entry-points (list (list '**tag** (car lap-code))))
(constants-list nil)
(nconstants 0)
(nlocals 0)
(next-local 0)
(closed-var-count-list (cons 0 closed-var-count-list))
(closure-vector-home nil)
(uncertain-nspecials nil)
(returns-single-value t)
(old-error-count error-count)
(vars-griped-about nil)
(current-function-form form)
(current-arglist (cadr form))
(function-entry-venv nil)
(max-args 0)
(min-args 0)
(rest-arg-present nil)
(rest-arg-entry-point nil)
(tail-recursion-tag (new-internal-tag))
(body (parse-body1 (cddr form)))
(decls (car body))
(doc (cadr body)))
;; This is only thrown to from the %tail-recursion-marker pass 2 function.
;; This means that compile is called recursively and that value is thrown
;; back, with the rest of this compilation being blown off.
(catch '%tail-recursion-elimination-abort
(setq body `(block ,function-name ,@(caddr body)))
(when doc
(process-random `(%put ',function-name '%fun-documentation ',doc)))
(when (eq function-type 'closure)
(setq uncertain-nspecials t))
(binding-contour decls
(cg-lambda-list current-arglist)
(setq function-entry-venv *venv*)
(inst-out tail-recursion-tag)
(cg-form body 'tail)
(inst-out `(return stack ,@(when (and annotate-special-bindings
(not uncertain-nspecials))
`((special-bindings ,nspecials)))
,@(when returns-single-value
'((single-value)))))
(setq lap-code (nreverse lap-code))
(pass-2)
(setq entry-points (nreverse entry-points))
(setq constants-list (nreverse constants-list))
;; Check for various illegal conditions.
(check-used)
(if (> min-args 255)
(clc-error "Too many required arguments: ~S" min-args))
(if (> max-args 255)
(clc-error "Too many allowed arguments: ~S" max-args))
(if (> nlocals 2047)
(clc-error "Too many local variables: ~S" nlocals))
(if (eq function-type 'closure)
(setq function-type 'expr))
(if (eq function-type 'fexpr)
(if (not (and (= max-args 1) (= min-args 1) (not rest-arg-present)))
(clc-error "Fexprs must have exactly one arg.")))
(if (eq function-type 'expr)
(note-args function-name min-args max-args rest-arg-present))
;; Note record function-type or peep optimize one shot functions.
(unless (eq function-type 'one-shot)
(note-type function-name function-type)
(if *peep-enable* (peephole-optimize)))
(if (or *clc-lap-stream* *compile-to-lisp*)
(setq lap-function (make-lap-function)))
(if *clc-lap-stream* (odd-print lap-function *clc-lap-stream*))
(if (or *clc-fasl-stream* *compile-to-lisp*)
(setq function-object (make-fasl)))
(when *verbose*
(if (= error-count old-error-count)
(clc-mumble "~%~S compiled." function-name)
(clc-mumble "~%~S did not compile successfully." function-name)))
(setq unknown-functions (delq function-name unknown-functions))
(when *compile-to-lisp*
(if (zerop function-level)
(push (cons function-name
(if (eq function-type 'macro)
(cons 'macro function-object)
function-object))
*function-definitions-to-set-up*)
(setf (symbol-function function-name) function-object)))
(if *compile-to-lisp* function-object nil)))))
(defun make-lap-function ()
`(spice-lap
(lap-code-for ,function-name)
,@(cond ((eq function-type 'fexpr) '((construct-fexpr)))
((eq function-type 'macro) '((construct-macro)))
((memq function-type '(expr one-shot)) nil)
(t (error "Bogus function type: ~S" function-type) nil))
(entry-points ,entry-points)
(constants-list ,constants-list)
(arglist ,current-arglist)
(max-args ,max-args)
(min-args ,min-args)
,@(if rest-arg-present '((rest-arg-present)) '())
(number-of-locals ,nlocals)
. ,lap-code))
;;; The following is a cheap pretty-printer for LAP code.
(defun odd-print (list stream)
(terpri stream)
(terpri stream)
(princ "(" stream)
(princ (car list) stream)
(dolist (x (cdr list))
(print x stream))
(princ ")" stream))
;;;; LAMBDA-LIST HACKERY
;;; CG-LAMBDA-LIST processes the extended-format arglist for a lambda.
;;; This is called within the binding-contour call for a Lambda being compiled.
;;; Code to do the actual binding is extruded into LAP-CODE, and the
;;; corresponding data structures are built up, particularly *VENV*.
;;; Tags for the various entry points are pushed on the ENTRY-POINTS list.
(defun cg-lambda-list (arglist)
(let ((prefix-code nil)
(vars-upstream nil)
(skip-tag nil))
(do ((a arglist (cdr a))
(arg nil))
((atom a) (finish-frame nil max-args))
(setq arg (car a))
(cond ((eq arg '&optional)
(return (cg-optional (cdr a))))
((eq arg '&rest)
(return (cg-rest (cdr a) nil)))
((eq arg '&key)
;; Add an imaginary &rest arg before the &key.
(return (cg-rest (cons (new-internal-variable) a) nil)))
((eq arg '&aux)
(finish-frame nil max-args)
(return (cg-bind-auxen (cdr a))))
((eq arg '&allow-other-keys)
(clc-warning "Stray &allow-other-keys in lambda-list, ignoring."))
((cg-required-arg arg))))))
;;; Finish-Frame completes the call frame. The %FINISH-FRAME pseudo
;;; instruction will be expanded in pass 2 into code that pushes the
;;; proper number of NILS for unsupplied args and for locals. If a
;;; vector of closure variables is needed, code to create this is also
;;; deposited when %FINISH-FRAME is expanded in pass 2. Following
;;; this, a copy of the prefix code is deposited. If a Skip-Tag is
;;; supplied, someone wants to jump over all this because the frame
;;; was completed earlier along another branch.
(defun finish-frame (skip-tag args-pushed)
(inst-out `(%finish-frame ,args-pushed))
(setq lap-code (append prefix-code lap-code))
(if skip-tag (inst-out skip-tag)))
;;; CG-BIND-AUXEN binds a list of &AUX args as for a LET*.
(defun cg-bind-auxen (aux-list)
(dolist (a aux-list)
(cond ((symbolp a)
(cg-form nil t)
(cg-bind-pop a))
((atom (cdr a))
(cg-form nil t)
(cg-bind-pop (car a)))
(t (cg-form (cadr a) t
(and *number-type-annotations*
(let ((x (assq (car a) new-type-decls)))
(and x (subtypep (cdr x) 'fixnum)))))
(cg-bind-pop (car a))))))
;;; CG-REQUIRED-ARG processes a single symbol as a required argument.
;;; If the arg is special, gernerate code to do the binding and put this
;;; into the Prefix-Code list. We must arrange for each of the entry
;;; points to execute Prefix-Code once. Often, we can delay depositing
;;; this code until after all of the entry points have been passed, and
;;; therefore just create one copy. However, if we run into an optional
;;; argument init that might look at a variable bound upstream or any
;;; occurrence of a supplied-p variable, we deposit the prefix code
;;; at once and complete the call frame by pushing NIL for all locals.
;;; Once this has been done, we must deposit this same code at each entry
;;; point farther on.
(defun cg-required-arg (v)
(cg-bind-arg v max-args nil t)
(push v vars-upstream)
(setq max-args (1+ max-args)
min-args (1+ min-args)))
;;; CG-BIND-ARG sets up the *VENV* entry for an argument to be bound.
;;; If the arg is special or if it is a lexical that becomes a closure,
;;; we need to move the arg value from the stack to somewhere else.
;;; If Now is on, deposit the code here for execution. If Later is on,
;;; push it onto Prefix-Code for execution at later entry points.
(defun cg-bind-arg (var arg-index now later)
(let (entry home temp)
(cond ((not (test-varname var)) nil)
((memq var new-specials)
;; The entry should already be on *VENV*.
(setq entry (assq var *venv*))
(setq nspecials (1+ nspecials))
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(setq temp `(push (arg ,arg-index)))
(when now (push temp lap-code))
(when later (push temp prefix-code))
(setq temp `(bind (constant ,(venv-home (cdr entry)))))
(when now (push temp lap-code))
(when later (push temp prefix-code)))
((or (get var 'globally-special)
(get var 'globally-special-in-compiler))
(setq entry (cons var (make-venv t function-level)))
(setq home (make-const var))
(setf (venv-home (cdr entry)) home)
(setq nspecials (1+ nspecials))
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(push entry *venv*)
(setq temp `(push (arg ,arg-index)))
(when now (push temp lap-code))
(when later (push temp prefix-code))
(setq temp `(bind (constant ,home)))
(when now (push temp lap-code))
(when later (push temp prefix-code)))
(t (setq entry (cons var (make-venv nil function-level)))
(setq home `(arg ,arg-index))
(setf (venv-home (cdr entry)) home)
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(push entry *venv*)
(setq temp `(%lexical-arg-setup ,entry))
(when now (push temp lap-code))
(when later (push temp prefix-code))))))
;;; CG-BIND-POP emits the code to bind a variable to a value popped off the
;;; stack. Does lots of bookkeeping in the environment. Call this only
;;; within a binding contour. If HOME is supplied, use that as the home
;;; for the variable if it is lexical. Else, grab a new local slot.
;;; Return a form that does what the deposited code does, without the
;;; book-keeping.
(defun cg-bind-pop (var &optional home)
(let (entry temp)
(cond ((not (test-varname var)) nil)
((memq var new-specials)
;; The entry should already be on *VENV*.
(setq entry (assq var *venv*))
(setq nspecials (1+ nspecials))
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(setq temp (venv-home (cdr entry)))
(inst-out `(bind (constant ,temp)))
`(pop (special ,temp)))
((or (get var 'globally-special)
(get var 'globally-special-in-compiler))
(setq entry (cons var (make-venv t function-level)))
(setq home (make-const var))
(setf (venv-home (cdr entry)) home)
(setq nspecials (1+ nspecials))
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(push entry *venv*)
(inst-out `(bind (constant ,home)))
`(pop (special ,home)))
(t (setq entry (cons var (make-venv nil function-level)))
(or home (setq home `(local ,(get-local))))
(setf (venv-home (cdr entry)) home)
(if (setq temp (assq var new-type-decls))
(setf (venv-declared-type (cdr entry)) (cdr temp)))
(push entry *venv*)
(inst-out `(%lexical-pop ,entry))
`(%lexical-pop ,entry)))))
;;; CG-OPTIONAL takes the portion of an arglist after the &OPTIONAL flag
;;; and continues digesting it.
(defun cg-optional (arglist)
(do ((a arglist (cdr a))
(arg nil))
((atom a) (finish-frame skip-tag max-args))
(setq arg (car a))
(cond ((eq arg '&rest)
(return (cg-rest (cdr a) skip-tag)))
((eq arg '&key)
(return (cg-rest (cons (new-internal-variable) a) nil)))
((eq arg '&aux)
(finish-frame skip-tag max-args)
(return (cg-bind-auxen (cdr a))))
((eq arg '&allow-other-keys)
(clc-warning "Stray &allow-other-keys in lambda-list, ignoring."))
((eq arg '&optional)
(clc-error "&Optional appers more than once.")
(return nil))
((atom arg)
(cg-optional-arg arg nil nil))
((atom (cdr arg))
(cg-optional-arg (car arg) nil nil))
((atom (cddr arg))
(cg-optional-arg (car arg) (cadr arg) nil))
((atom (cdddr arg))
(cg-optional-arg (car arg) (cadr arg) (caddr arg)))
(t (clc-error "Illegal item in arglist: ~S" arg)))))
;;; CG-OPTIONAL-ARG gets the three elements of an optional argument plus
;;; a skip tag or NIL. If there is a skip tag, it means that someone
;;; upstream has already executed the prefix code and completed the
;;; frame and wants to skip any repetition of that code. If the init
;;; for this optional might reference variables bound upstream or if
;;; there is a supplied-p variable, we have to dump the prefix code
;;; and finish the frame here. Any function call in the init is
;;; assumed to reference vars upstream.
(defun cg-optional-arg (v init vp)
(prog (entry-tag temp)
(setq entry-tag (new-internal-tag))
(push `(**tag** ,entry-tag) entry-points)
(cond ((and (null skip-tag)
(null vp)
(or (null init)
(constantp init)
(and (symbolp init)
(not (memq init vars-upstream)))))
;; Frame is not finished and it is safe to go on this way.
(push v vars-upstream)
;; Deposit the init value in the proper place on the stack.
(cg-form init t)
;; Arrange to move it later if necessary.
(cg-bind-arg v max-args nil t)
;; Jump in here if this value was supplied.
(inst-out entry-tag)
(setq max-args (1+ max-args)))
(t
;; We must finish the frame for code entering here.
(finish-frame skip-tag max-args)
(cg-form init t
(and *number-type-annotations*
(let ((x (assq v new-type-decls)))
(and x (subtypep (cdr x) 'fixnum)))))
(inst-out `(pop (arg ,max-args)))
(cg-bind-arg v max-args t t)
(when vp
(cg-form nil t)
(setq temp (cg-bind-pop vp))
(push '(set-t stack) prefix-code)
(push temp prefix-code))
(setq skip-tag (new-internal-tag))
(inst-out `(branch ,skip-tag))
(inst-out entry-tag)
(setq max-args (1+ max-args))))))
;;; CG-REST receives the part of the arglist after &REST and a skip-tag if
;;; earlier arguments have deposited prefix code and completed the frame.
;;; If excess args are passed, we enter the code vector at the start,
;;; listify the arguments on the stack, then jump into the Lap code and
;;; treat the &rest arg as a very simple optional. Finally look for
;;; &aux args and finish up.
(defun cg-rest (arglist skip-tag)
(prog (v)
(cond ((atom arglist)
(clc-error "Ill-formed &REST arg.")
(return nil))
((memq (setq v (car arglist))
'(&optional &rest &key &aux &allow-other-keywords))
(clc-error "~S in illegal place in arglist." v)
(return nil))
((not (test-varname v))
(return nil)))
(setq rest-arg-present t)
(when *all-rest-args-are-lists*
(push (cons v 'list) new-type-decls))
(setq rest-arg-entry-point (new-internal-tag))
;; If there are excess args, entry point is at start of code vector.
;; Slip the branch in there.
(rplacd lap-code-start
(list `(branch ,rest-arg-entry-point) '(code-start)))
(inst-out '(set-null stack))
(inst-out rest-arg-entry-point)
(finish-frame skip-tag (1+ max-args))
(cg-bind-arg v max-args t nil)
(cond ((atom (cdr arglist)))
((eq (cadr arglist) '&key)
(cg-keys (cddr arglist) v))
((eq (cadr arglist) '&aux)
(cg-bind-auxen (cddr arglist)))
(t (clc-error "Illegal stuff after &REST arg.")))))
;;; CG-KEYS deposits code to bind the keyword variables to the proper
;;; arguments or default values. Varlist is everything following &KEY
;;; in the lambda-list. Rest-var is the name of the &rest variable.
;;; This always exists and has already been set up. The frame has been
;;; completed.
(defun cg-keys (varlist rest-var)
(let ((temp-var (new-internal-variable)))
(cg-form nil t)
(cg-bind-pop temp-var)
(do ((vl varlist (cdr vl))
(check-keywords *check-keywords-at-runtime*)
(seen-keywords nil (cons key seen-keywords))
(key nil)
(item nil))
((atom vl)
(if check-keywords
(cg-form `(keyword-test ,rest-var ',seen-keywords) nil)))
(setq item (car vl))
(cond ((eq item '&aux)
(if check-keywords
(cg-form `(keyword-test ,rest-var ',seen-keywords) nil))
(return (cg-bind-auxen (cdr vl))))
((eq item '&allow-other-keys)
(setq check-keywords nil))
((symbolp item)
(setq key (make-keyword item))
(cg-key item key nil nil rest-var temp-var))
((atom item)
(clc-error "Non-symbol used as variable name."))
((symbolp (car item))
(setq key (make-keyword (car item)))
(cond ((atom (cdr item))
(cg-key (car item) key nil nil rest-var temp-var))
((atom (cddr item))
(cg-key (car item) key (cadr item) nil rest-var temp-var))
((null (cdddr item))
(cg-key (car item) key (cadr item) (caddr item)
rest-var temp-var))
(t (clc-error "Ill-formed keyword item in lambda list."))))
((and (consp (car item))
(symbolp (caar item))
(consp (cdar item))
(symbolp (cadar item)))
(setq key (caar item))
(cond ((atom (cdr item))
(cg-key (cadar item) key nil nil rest-var temp-var))
((atom (cddr item))
(cg-key (cadar item) key (cadr item) nil
rest-var temp-var))
((null (cdddr item))
(cg-key (cadar item) key (cadr item) (caddr item)
rest-var temp-var))
(t (clc-error "Ill-formed keyword item in lambda list."))))
(t (clc-error "Ill-formed keyword item in lambda list."))))))
;;; Generate the keyword-setup as source-level code, let the compiler do the
;;; work.
(defun cg-key (var key init varp rest-var temp-var)
(cg-form
`(progn (setq ,temp-var (%get-key ,rest-var ,key))
(%bind ,var (if ,temp-var (car ,temp-var) ,init))
,@(if varp `((%bind ,varp (not (not ,temp-var))))))
nil))
;;; A pseudo-function for use inside the compiler.
;;; Never call this for value, and never call it more than once on the same
;;; incarnation of VAR, even if only one call will be executed. CG-BIND-POP
;;; has some nasty side effects.
(def-cg %bind %bind-cg (var val)
(cg-form val t
(and *number-type-annotations*
(let ((x (assq var new-type-decls)))
(and x (subtypep (cdr x) 'fixnum)))))
(cg-bind-pop var))
;;;; TRANSFORM
;;; Transform does assorted source-to-source transformations before we get
;;; down to the real business of compiling a form.
;;; Transform takes a form, checks for the proper length if this is known,
;;; and applies any macros, inline expansions or lisp-to-lisp transforms
;;; that have been defined for the form. If anything gets changed, we run
;;; the new form through again until quiescence is reached. A single
;;; function may have multiple transforms, and we are not done until all
;;; have passed the form with no changes.
;;; A transform that doesn't want to change the form should return %PASS%.
;;; If called while processing a top-level form, decline to transform
;;; certain special forms.
(defun transform (form &optional at-top-level)
(prog (temp)
loop
(cond ((symbolp form)
(return (transform-symbol form)))
((atom form) (return form))
((not (symbolp (car form)))
(cond ((and (consp (car form)) (eq (caar form) 'lambda))
;; Turn car-position lambda form into equivalent let form.
;; Lambdas containing &key become Apply forms.
(setq form
(if (memq '&key (cadar form))
`(funcall (function ,(car form)) ,@(cdr form))
(multiple-value-bind
(bind body)
(optimize-let-bindings
(lambda-to-let (cadar form) (cdr form))
(cddar form)
nil)
`(let ,bind ,@body))))
(go loop))
;; Some bogus thing in car of the form.
(t (clc-error
"Function must be a symbol or lambda form: ~S"
(car form))
(return nil))))
;; If at "top level", don't transform certain things.
((and at-top-level (memq (car form)
'(defun macro eval-when defconstant)))
(return form))
;; Don't try to macroexpand %primitive things; that's just for the
;; interpreter. Leave it alone and let CG take care of it.
((eq (car form) '%primitive)
(return form))
;; See if this is a lexically bound function or macro.
((and *fenv* (setq temp (assq (car form) *fenv*)))
(cond ((symbolp (cdr temp))
(setq form `(funcall ,(cdr temp) ,@(cdr form)))
(go loop))
(t (setq form (funcall (cdr temp) form))
(go loop))))
;; Check the arg count.
((not (check-args form))
(return nil))
;; Macros seen by the compiler are recorded as MACRO-IN-COMPILER.
;; These get priority over any macros lying around in the Lisp.
((setq temp (get (car form) 'macro-in-compiler))
(setq form (funcall temp form))
(go loop))
;; Might be defined as a macro in this Lisp environment.
((setq temp (macro-function (car form)))
(let ((optimize-let (and (eq t *optimize-let-bindings*)
(memq (car form) '(setf psetf)))))
(setq form (funcall temp form))
(if (and optimize-let (memq (car form) '(let let*)))
(multiple-value-bind (bindings body)
(optimize-let-bindings
(cadr form) (cddr form)
(eq (car form) 'let*))
(setf (cadr form) bindings)
(setf (cddr form) body))))
(go loop))
;; Expand functions declared inline.
((and *inline-enable*
(setq temp (get (car form) 'inline-expansion))
(cdr (assq (car form) inlines)))
(cond ((eq temp t)
(clc-comment
"~S supposed to be inline, but no definition stored. ~
Compiling it as a normal function call."
(car form))
(return form))
;; The expander is a lambda form, graft it on.
(t (setq form (cons temp (cdr form)))
(go loop))))
;; If not for value and expr with no side-effects, turn to PROGN.
((and (not for-value) (get (car form) 'expr-with-no-side-effects))
(setq form `(progn ,@(cdr form) nil))
(go loop))
;; Replace synonyms.
((setq temp (get (car form) 'synonym))
(setq form (cons temp (cdr form)))
(go loop))
;; Now run transforms, and repeat the loop if any of them fire.
((do ((trans (get (car form) 'clc-transforms) (cdr trans)))
((null trans) nil)
(setq temp
(catch 'pass-catcher (funcall (car trans) form)))
(unless (eq temp '%pass%)
(setq form temp)
(return t)))
;; If the transform changed anything, go around again.
(go loop))
;; No transforms or all of them passed. Done.
(t (return form)))))
;;; Transform-symbol handles symbols for transform. If the symbol is a
;;; defconstant in the compiler or in the surrounding Lisp, and if the
;;; value is simple enough, replace the form with the value. Else just
;;; return the form.
(defun transform-symbol (form)
(cond ((get form 'constant-in-compiler)
(let ((temp (get form 'constant-value)))
(cond ((or (characterp temp)
(numberp temp)
(and (listp temp)
(eq (car temp) 'quote)
(symbolp (cadr temp))))
temp)
(t form))))
((get form '%constant)
(let ((temp (symbol-value form)))
(cond ((or (numberp temp)
(characterp temp))
temp)
((symbolp temp)
(list 'quote temp))
(t form))))
(t form)))
;;; CHECK-ARGS is compares the number of "arguments" to a function, macro,
;;; or special form with the allowed minimum and maximum counts for that
;;; form, if these limits are known. The limits are found in the
;;; CLC-ARGS property of the symbol as (min . max), where max may
;;; be NIL (meaning infinity).
(defun check-args (form)
(let ((nallowed (get-function-arg-counts (car form))))
(if (null nallowed) t
;; Count "args" and then compare to limits.
(do* ((nargs 0 (1+ nargs))
(f (cdr form) (cdr f)))
((atom f)
(cond ((< nargs (car nallowed))
(clc-error
"~S called with ~S args, wanted at least ~S."
(car form) nargs (car nallowed))
nil)
((and (cdr nallowed)
(> nargs (cdr nallowed)))
(clc-error
"~S called with ~S args, wanted at most ~S."
(car form) nargs (cdr nallowed))
nil)
(t t)))))))
;;;; BASIC CODE-GENERATION LOOP.
;;; CG-Form generates code for a single form, anything but a top-level
;;; lambda. It is also given a flag indicating whether the form is
;;; being called for value. The form is first transformed, then code is
;;; deposited on the Lap-code list. In a few cases, such as references to
;;; lexical variables, the exact code to be deposited cannot be determined
;;; until the whole form has been processed. In such cases, a pseudo-code
;;; is placed on the Lap list. A quick second pass resolves these codes
;;; into real instruction sequences.
(defun function-type (fn)
(cond ((get-declared-function-type fn))
((and *compile-to-lisp* (fboundp fn)) 'expr)))
(defun cg-form (form for-value &optional (fixnum-output nil))
(let (fn temp)
(setq form (transform form))
(cond ((atom form)
(cg-atomic form))
((eq (setq fn (car form)) 'quote)
(cg-constant (cadr form)))
;; Is there a special code generator for this form?
((setq temp (get fn 'cg))
(funcall temp form))
;; Is it a primitive in the instruction set?
((get fn 'primitive-operation)
(cg-primitive form))
;; Known to be an expr?
((eq (setq temp (function-type fn)) 'expr)
(cg-expr-call form))
;; Known to be a fexpr?
((eq temp 'fexpr)
(cg-fexpr-call form))
;; Else, assume that it is an expr.
(t (assume-expr fn (length (cdr form)))
(cg-expr-call form)))))
;;; CG-CONSTANT adds its arg to the constants list and generates code to
;;; reference this constant. Some special cases get instructions of their
;;; own.
(defun cg-constant (form)
(cond ((not for-value) nil)
((eq form nil) (inst-out '(set-null stack)))
((eq form t) (inst-out '(set-t stack)))
((and (integerp form) (= form 0)) (inst-out '(set-0 stack)))
((and (integerp form)
(not (> form most-positive-short-constant))
(not (< form most-negative-short-constant)))
(inst-out `(push (short-const ,form))))
(t (inst-out `(push (constant ,(make-const form)))))))
;;; CG-ATOMIC produces code for atomic forms. Only atoms to be evaluated
;;; should get in here. Go tags are picked off elsewhere.
(defun cg-atomic (form)
(let (entry)
(cond ((not for-value)
(setq entry (assq form *venv*))
(if entry (setf (venv-usedp (cdr entry)) t))
nil)
((or (numberp form)
(characterp form)
(stringp form)
(bit-vector-p form))
(cg-constant form))
((not (symbolp form))
(clc-error "Illegal atomic form to eval: ~S" form)
nil)
((null form) (cg-constant form))
((eq form t) (cg-constant form))
((keywordp form) (cg-constant form))
((setq entry (assq form *venv*))
(cond ((venv-specialp (cdr entry))
(when (not (= (venv-function-level (cdr entry))
function-level))
;; Special inherited from lexically enclosing
;; function, got to make a copy in this function.
(setq entry (cons form (make-venv t function-level)))
(setf (venv-home (cdr entry)) (make-const form))
(push entry *venv*))
(inst-out `(push (special ,(venv-home (cdr entry))))))
((not (= (venv-function-level (cdr entry))
function-level))
(setf (venv-closure-index (cdr entry))
(get-closure-index entry))
(setf (venv-usedp (cdr entry)) t)
(inst-out `(%closure-push ,entry ,function-level)))
(t (setf (venv-usedp (cdr entry)) t)
(inst-out `(%lexical-push ,entry)))))
((or (get form 'globally-special-in-compiler)
(get form 'globally-special))
(inst-out `(push (special ,(make-const form)))))
(t (unless (memq form vars-griped-about)
(clc-warning "~S not declared or bound, assuming special."
form)
(pushnew form unknown-free-vars)
(push form vars-griped-about))
(inst-out `(push (special ,(make-const form))))))))
;;; Generate code for a primitive that has its own operator in the byte
;;; coded instruction set. For now we assume that no one will pass us
;;; non stack-popping, stack-returning things.
(def-cg %primitive %primitive-cg (name &rest args)
(let ((*benv* (cons '(%garbage) *benv*)))
(dolist (arg args) (cg-form arg t)))
(cond (for-value
(inst-out `(,name stack)))
(t
(inst-out `(,name stack))
(inst-out '(pop ignore)))))
;;; Generate code for a function that has an instruction which implements it.
;;; We save a little consing by not going through %PRIMITIVE-CG.
(defun cg-primitive (form)
(let ((*benv* (cons '(%garbage) *benv*)))
(dolist (arg (cdr form)) (cg-form arg t)))
(inst-out `(,(get (car form) 'primitive-operation) stack))
(unless for-value
(inst-out '(pop ignore))))
;;; Generate code for a call to a random EXPR.
(defun cg-expr-call (form)
(let ((tag (new-internal-tag))
(nargs (length (cdr form))))
(cond ((and (eq function-name (car form))
(eq for-value 'tail)
*eliminate-tail-recursion*
(no-garbage-on-stack-p *benv*)
(<= min-args nargs)
(or (<= nargs max-args) rest-arg-present))
(eliminate-tail-recursion form))
((or (eq for-value 'multiple) (eq for-value 'tail))
(inst-out `(call-multiple (constant ,(make-const (car form)))
(return-address ,tag)))
(dolist (x (cdr form)) (cg-form x t))
(inst-out `(push-last stack
(return-tag ,tag)
#',(car form)
(nargs ,nargs nil))))
((not (zerop (length (cdr form))))
(inst-out `(call (constant ,(make-const (car form)))
(return-address ,tag)))
(let ((*benv* (cons '(%garbage) *benv*)))
(dolist (x (cdr form)) (cg-form x t)))
(inst-out `(push-last stack
(return-tag ,tag)
(function ,(car form))
(nargs ,nargs nil))))
;; No args, so call-0 can be used.
(t (inst-out `(call-0 (constant ,(make-const (car form))))))))
;; Flush result if not for value.
(if (not for-value) (inst-out `(pop ignore)))
;; See if we can still guarantee that the function returns only
;; a single value.
(when (and (eq for-value 'tail)
(not (get (car form) 'single-value)))
(setq returns-single-value nil)))
;;; Generate a call to a Fexpr.
(defun cg-fexpr-call (form)
(cg-expr-call (list (car form) (cons 'quote (cdr form)))))
;;;; TAIL RECURSION HACKERY.
;;; This code attempts to compile a tail-recursive call to the current
;;; function into a PSETQ and a jump. For now, only the simplest cases
;;; are handled: the function must have no key, aux, or rest args, no
;;; args that are special, no args shadowed by more local bindings, and
;;; any init forms for optional args must be constants. It wouldn't be
;;; too hard to loosen up some of these restrictions, but it wouldn't
;;; buy us much either.
;;; We make a pass through the function's arglist, making sure that all
;;; the restrictions hold and building up the PSETQ arguments. At the
;;; first sign of any trouble, we simply punt and compile this call the
;;; normal way.
;;; If we do eliminate the recursive call, we deposit a marker so that
;;; we can reconsider this move during PASS-2. In some rare situations,
;;; there will by then be garbage on the stack, and we must not iterate
;;; after all. In such cases, we simply redo the compilation of this form
;;; from the top, with tail-recursion hackery turned off.
(defun eliminate-tail-recursion (form)
(or (do ((al current-arglist (cdr al))
(vl (cdr form))
(psetq-args nil)
(optionalp nil)
a temp)
((null al)
(inst-out `(%tail-recursion-marker ,*benv*))
(cg-form `(psetq ,@(nreverse psetq-args)) nil)
(inst-out `(branch ,tail-recursion-tag))
t)
(setq a (car al))
(cond
;;; For now, punt if we see any key, rest, or aux args.
((memq a '(&key &rest &aux &allow-other-keys))
(return nil))
;;; If we see the optional marker, note that.
((eq a '&optional)
(setq optionalp t))
;;; If we have a symbol and it is not special and not shadowed by
;;; an intervening binding, build the PSETQ entry.
((symbolp a)
(cond ((and (setq temp (assq a *venv*))
(eq temp (assq a function-entry-venv))
(not (venv-specialp (cdr temp)))
(or optionalp (not (atom vl))))
(push a psetq-args)
(push (car vl) psetq-args)
(setq vl (cdr vl)))
(t (return nil))))
;;; If we have a simple list-type optional and the value is either
;;; supplied or contant, build the PSETQ entry.
((and (consp a)
optionalp
(null (cddr a))
(or (null (cdr a)) (constantp (cadr a))))
(cond ((and (setq temp (assq (car a) *venv*))
(eq temp (assq (car a) function-entry-venv))
(not (venv-specialp (cdr temp))))
(push (car a) psetq-args)
(push (if (consp vl)
(car vl)
(cadr a)) psetq-args)
(setq vl (cdr vl)))
(t (return nil))))
(t (return nil))))
(let ((*eliminate-tail-recursion* nil))
(cg-expr-call form))))
;;; If we see a tail recursion marker, make sure that nothing the tail recursion
;;; is going to branch around has turned into a catch. If it has, we have to
;;; trash this compilation and try it again from the top with no tail
;;; recursion allowed this time. Total restarts of this type should be rare.
(def-p2 %tail-recursion-marker %tail-recursion-marker-p2 (benv)
(if (no-garbage-on-stack-p benv)
nil
(let ((*eliminate-tail-recursion* nil))
(throw '%tail-recursion-elimination-abort
(compile-one-lambda current-function-form)))))
;;;; PASS 2
;;; Certain decisions about what code to generate must wait until the
;;; entire function has been examined. By the end of the CG phase, all
;;; of the necessary info is in place, and psuedo-ops have been placed in
;;; the lap-code list to mark where new code must be generated.
;;; PASS-2 first makes a pass over the major data structures such as *VENV*,
;;; then scans the LAP code list looking for psudo-ops. Each type of
;;; pseudo-op has a P2 expander function, which returns a code fragment to
;;; be spliced into the Lap-code list.
(defun pass-2 ()
;; Assign a local slot for the closure vector, if one is needed.
(unless (zerop (car closed-var-count-list))
(setq closure-vector-home nlocals)
(setq nlocals (1+ nlocals)))
;; The following kludge is to keep locals from popping into the
;; Perq's TOS register.
(if (eq target-machine 'perq) (setq nlocals (1+ nlocals)))
(do* ((lc lap-code (cdr lc))
(i nil)
(p2 nil))
((null (cdr lc)))
LOOP
(setq i (cadr lc))
(setq p2 (and (consp i) (get (car i) 'p2)))
(when p2
(setq p2 (funcall p2 i))
(cond (p2 (rplacd lc (append p2 (cddr lc))))
(t (rplacd lc (cddr lc))
(go loop))))))
;;; References are either to local variables or to slots in the closure
;;; vector. Push the value onto the stack in either case.
(def-p2 %lexical-push %lexical-push-p2 (entry)
(let ((index (venv-closure-index (cdr entry))))
(if index
(progn (setq index
(if (not (> index most-positive-short-constant))
`(short-const ,index)
`(constant ,(make-const index))))
`((push (local ,closure-vector-home))
(push ,index)
(svref stack (no-check))))
`((push ,(venv-home (cdr entry)))))))
;;; Pop the value on top of the stack into the proper lexical variable,
;;; either a local or a slot in the closure vector. Because of ugly
;;; argument order, pop into closure vector by way of the var's old
;;; home slot.
(def-p2 %lexical-pop %lexical-pop-p2 (entry)
(let ((index (venv-closure-index (cdr entry))))
(if index
(progn
(setq index
(if (not (> index most-positive-short-constant))
`(short-const ,index)
`(constant ,(make-const index))))
`((push (local ,closure-vector-home))
(exchange stack)
(push ,index)
(exchange stack)
(svset stack (no-check))
(pop ignore)))
`((pop ,(venv-home (cdr entry)))))))
;;; Closures always get the lexical environment via the special
;;; variable %lexical-environment%. This is
;;; a list of closure vectors. Cdr back the right number of levels,
;;; then access the proper slot in the vector.
(def-p2 %closure-push %closure-push-p2 (entry level)
`((push (special ,(make-const '%lexical-environment%)))
,@(do ((n (1+ (venv-function-level (cdr entry))) (1+ n))
(cdrs nil (cons '(cdr stack) cdrs)))
((= n level) cdrs))
(car stack)
(push ,(let ((index (venv-closure-index (cdr entry))))
(if (not (> index most-positive-short-constant))
`(short-const ,index)
`(constant ,(make-const index)))))
(svref stack (no-check))))
;;; Similar ugly problem with order of args to svset, hence the
;;; shuffling.
(def-p2 %closure-pop %closure-pop-p2 (entry level)
`((push (special ,(make-const '%lexical-environment%)))
,@(do ((n (1+ (venv-function-level (cdr entry))) (1+ n))
(cdrs nil (cons '(cdr stack) cdrs)))
((= n level) cdrs))
(car stack)
(exchange stack)
(push ,(let ((index (venv-closure-index (cdr entry))))
(if (not (> index most-positive-short-constant))
`(short-const ,index)
`(constant ,(make-const index)))))
(exchange stack)
(svset stack (no-check))
(pop ignore)))
;;; This psuedo-op moves a supplied arg into the closure vector if necessary.
(def-p2 %lexical-arg-setup %lexical-arg-setup-p2 (entry)
(let ((index (venv-closure-index (cdr entry))))
(if index
(progn
(setq index
(if (not (> index most-positive-short-constant))
`(short-const ,index)
`(constant ,(make-const index))))
`((push (local ,closure-vector-home))
(push ,index)
(push ,(venv-home (cdr entry)))
(svset stack (no-check))
(pop ignore)))
nil)))
(def-p2 %finish-frame %finish-frame-p2 (nargs)
(let (more cv-code count)
(setq count (car closed-var-count-list))
(unless (zerop count)
(setq cv-code `((push ,(if (> count
most-positive-short-constant)
`(constant ,(make-const count))
`(short-const ,count)))
(set-null stack)
(alloc-g-vector stack)
(pop (local ,closure-vector-home)))))
(setq more (+ max-args nlocals (if rest-arg-present 1 0) (- nargs)))
(if (< (- more) most-negative-short-constant)
`((npop (constant ,(make-const (- more))))
,@cv-code)
`((npop (short-const ,(- more)))
,@cv-code))))
;;; This turns into code that conses the current closure-vector to the
;;; lexical environment list coming into the function (if it is a closure).
;;; This is the object passed to a closure as its lexical environment.
(def-p2 %make-lexical-environment %make-lexical-environment-p2 ()
`(,(if closure-vector-home
`(push (local ,closure-vector-home))
'(set-null stack))
,(if (eq function-type 'closure)
`(push (special ,(make-const '%lexical-environment%)))
'(set-null stack))
(cons stack)))
;;; FUNCTION
;;; The ever-popular FUNCTION special form. If the arg is a symbol, just
;;; return its definition. If it is a lambda, the real fun begins. Make
;;; some funny notations in the environment, make up a name, and then just
;;; call COMPILE-ONE-LAMBDA recursively. The code for the embedded function
;;; will be assembled and dumped before we get back to the caller. Then
;;; just return SYMBOL-FUNCTION of the made-up name.
(def-cg function cg-function (arg)
(cg-function1 arg (breakoff-name)))
(defun cg-function1 (arg name)
(cond ((symbolp arg)
(let ((entry (and *fenv* (assq arg *fenv*))))
(cond ((null entry)
(cg-form `(symbol-function (quote ,arg)) for-value))
((symbolp (cdr entry))
(cg-form (cdr entry) for-value))
(t (clc-error "~S locally defined to be a macro." arg)))))
((and (consp arg)
(consp (cdr arg))
(eq (car arg) 'lambda))
;; Compile the lambda under an assumed name. This sees the
;; surrounding lexical environment and leaves tracks if that
;; environment is actually used.
(let ((function-name name)
(function-type 'closure)
(function-level (1+ function-level)))
(compile-one-lambda arg))
;; If enclosing form is a closure or has close-referenced variables
;; at this point, produce a closure. Else, it is safe to just
;; return the compiled function object.
(if (or (not (zerop (car closed-var-count-list)))
(eq function-type 'closure))
(cg-form `(list '%compiled-closure%
(%make-lexical-environment)
(symbol-function ',name))
for-value)
(cg-form `(symbol-function ',name)
for-value)))
(t (clc-error "Ill-formed arg to FUNCTION: ~S" arg))))
;;; This just puts out a place-holder till pass 2.
(def-cg %make-lexical-environment cg-%make-lexical-environment ()
(inst-out '(%make-lexical-environment)))
;;;; *** Here begin the code generators for particular special forms. ***
;;;; SETQ & FRIENDS.
;;; This code generator handles only the two-arg form of SETQ. A transform
;;; turns multi-pair SETQ into the single-pair form.
(def-cg setq cg-setq (var val)
(cg-form val t
(and *number-type-annotations*
(subtypep (find-type var) 'fixnum)))
(cg-set1 var for-value))
;;; CG-SET1 emits code to pop one value into a specified variable.
(defun cg-set1 (var for-value)
(let (entry)
(test-varname var)
(if for-value (inst-out '(copy stack)))
(cond ((setq entry (assq var *venv*))
(cond ((venv-specialp (cdr entry))
(inst-out `(pop (special ,(venv-home (cdr entry))))))
((not (= (venv-function-level (cdr entry))
function-level))
(setf (venv-closure-index (cdr entry))
(get-closure-index entry))
(inst-out `(%closure-pop ,entry ,function-level)))
(t (inst-out `(%lexical-pop ,entry)))))
((or (get var 'globally-special-in-compiler)
(get var 'globally-special))
(inst-out `(pop (special ,(make-const var)))))
(t (unless (memq var vars-griped-about)
(clc-warning "~S not declared or bound, assuming special."
var)
(pushnew var unknown-free-vars)
(push var vars-griped-about))
(inst-out `(pop (special ,(make-const var))))))))
;;; PSETQ pushes values onto the stack, then pops them off and binds them
;;; to the variables in question. During this time, there is garbage on
;;; the stack. If a variable is not referenced downstream, we can set it
;;; right away. This enables certain other optimizations, so it is worth
;;; doing, especially given the number of bogus PSETQs generated by use of
;;; DO instead of DO*.
(def-cg psetq cg-psetq (&rest pairs)
(let ((vars nil)
(*benv* *benv*))
(do* ((m pairs (cddr m))
(var (car m) (car m)))
((atom m))
(cg-form (cadr m) t
(and *number-type-annotations*
(subtypep (find-type var) 'fixnum)))
(if (and (symbolp var)
(lexical-reference-p var)
(do ((x (cddr m) (cddr x)))
((null x) t)
(unless (contains-no-reference-to (cadr x) var)
(return nil))))
;; Lexical var with no references downstream. OK to set it now.
(cg-set1 var nil)
;; Must pop and set this later.
(progn (push var vars)
(push '%garbage *benv*))))
(dolist (v vars)
(cg-set1 v nil))
(if for-value (inst-out `(set-null stack)))))
(def-cg multiple-value-setq cg-multiple-value-setq (varlist mv-form)
(cond ((atom varlist)
(cg-form mv-form (and for-value t)))
(t (cg-form mv-form 'multiple)
(inst-out '(force-values stack))
(inst-out '(values-to-n stack))
(cg-form (length varlist) t)
(inst-out '(- stack))
(inst-out '(npop stack))
(do ((vl (reverse varlist) (cdr vl)))
((null (cdr vl))
(cg-set1 (car vl) for-value))
(cg-set1 (car vl) nil)))))
;;;; LET & FRIENDS.
;;; LET* establishes a binding contour and then binds the variables to
;;; the inits one by one.
(def-cg let* cg-let* (varlist &rest forms)
(let* ((pb (parse-body2 forms))
(decls (car pb))
(body (cadr pb)))
(if (eq *optimize-let-bindings* :all)
(multiple-value-setq (varlist body)
(optimize-let-bindings varlist body t)))
(binding-contour decls
(dolist (v varlist)
(cond ((symbolp v)
(cg-form nil t)
(cg-bind-pop v))
((atom (cdr v))
(cg-form nil t)
(cg-bind-pop (car v)))
((null (cddr v))
(cg-form (cadr v) t
(and *number-type-annotations*
(let ((x (assq (car v) new-type-decls)))
(and x (subtypep (cdr x) 'fixnum)))))
(cg-bind-pop (car v)))
(t (clc-error "Bad item in Let* binding list: ~S" v))))
(cg-progn-body body)
(check-used)
(unless (or (= nspecials old-nspecials)
(and (not annotate-special-bindings)
(eq for-value 'tail)))
(cg-form (- nspecials old-nspecials) t)
(inst-out '(unbind stack))))))
;;; LET is similar, but pushes all the values, then pops and binds them.
(def-cg let cg-let (varlist &rest forms)
(let* ((pb (parse-body2 forms))
(decls (car pb))
(body (cadr pb))
(var nil)
(vars nil))
(if (eq *optimize-let-bindings* :all)
(multiple-value-setq (varlist body)
(optimize-let-bindings varlist body nil)))
(binding-contour decls
(let ((*benv* *benv*))
(do* ((vl varlist (cdr vl))
(v (car vl) (car vl)))
((atom vl))
(cond ((symbolp v)
(cg-form nil t)
(setq var v))
((atom (cdr v))
(cg-form nil t)
(setq var (car v)))
((null (cddr v))
(cg-form (cadr v) t
(and *number-type-annotations*
(let ((x (assq (car v) new-type-decls)))
(and x (subtypep (cdr x) 'fixnum)))))
(setq var (car v)))
(t (clc-error "Bad item in Let binding list: ~S" v)))
(if (and (symbolp var)
(lexical-reference-p var)
(do ((x (cdr vl) (cdr x)))
((null x) t)
(unless (or (atom (car x))
(atom (cdar x))
(contains-no-reference-to (cadar x) var))
(return nil))))
;; Lexical var with no references downstream. OK to bind it now.
(cg-bind-pop var)
;; Must pop and bind this later.
(progn (push var vars)
(push '%garbage *benv*)))))
(dolist (v vars)
(cg-bind-pop v))
(cg-progn-body body)
(check-used)
(unless (or (= nspecials old-nspecials)
(and (not annotate-special-bindings)
(eq for-value 'tail)))
(cg-form (- nspecials old-nspecials) t)
(inst-out '(unbind stack))))))
;;; Get the multiple values on the stack, then pop and bind.
(def-cg multiple-value-bind
cg-multiple-value-bind (varlist mv-form &body forms)
(cg-form mv-form 'multiple)
(inst-out '(force-values stack))
(inst-out '(values-to-n stack))
(cg-form (length varlist) t)
(inst-out '(- stack))
(inst-out '(npop stack))
(let* ((pb (parse-body2 forms))
(decls (car pb))
(body (cadr pb)))
(binding-contour decls
(dolist (v (reverse varlist))
(cg-bind-pop v))
(cg-progn-body body)
(check-used)
(unless (or (= nspecials old-nspecials)
(and (not annotate-special-bindings)
(eq for-value 'tail)))
(cg-form (- nspecials old-nspecials) t)
(inst-out '(unbind stack))))))
;;; COMPILER-LET binds its variables as specials during compilation.
(def-cg compiler-let cg-compiler-let (varlist &rest body)
(let ((vars nil)
(varinits nil))
(dolist (v varlist)
(cond ((symbolp v)
(push v vars)
(push nil varinits))
((atom (cdr v))
(push (car v) vars)
(push nil varinits))
((null (cddr v))
(push (car v) vars)
(push (eval (cadr v)) varinits))
(t (clc-error "Bad item in Let binding list: ~S" v)
(push (car v) vars)
(push nil varinits))))
;; Now bind all vars before compiling body.
(progv (nreverse vars) (nreverse varinits)
(cg-progn-body body))))
;;;; FLET and friends.
(def-cg flet cg-flet (x &body body)
(let ((*fenv* *fenv*))
(do ((defs x (cdr defs))
(new-env *fenv*)
(let-list nil)
(name (new-internal-variable) (new-internal-variable)))
((atom defs)
;; Compile the functions. THEN set up the new fenv and compile
;; the body.
(cg-form
`(let ,(nreverse let-list)
(%with-fenv ,new-env ,@body))
for-value))
(push `(,name (function (lambda ,@(cdar defs)))) let-list)
(push (cons (caar defs) name) new-env))))
;;; Kludge used only in FLET. Other ways of doing this are even uglier.
(def-cg %with-fenv %with-fenv-cg (*fenv* &rest body)
(cg-progn-body body))
(def-cg labels cg-labels (x &body body)
(let ((*fenv* *fenv*))
(do ((defs x (cdr defs))
(new-env *fenv*)
(let-list nil)
(setq-list nil)
(name (new-internal-variable) (new-internal-variable)))
((atom defs)
(setq *fenv* new-env)
;; With new *FENV* bindings in effect, compile the functions,
;; then the body.
(cg-form
`(let ,let-list (setq ,@setq-list) (progn ,@body))
for-value))
(push name let-list)
(push `#'(lambda ,@(cdar defs)) setq-list)
(push name setq-list)
(push (cons (caar defs) name) new-env))))
(def-cg macrolet cg-macrolet (x &body body)
(let ((*fenv* *fenv*))
(do ((defs x (cdr defs))
(new-env *fenv*))
((atom defs)
(setq *fenv* new-env)
(cg-progn-body body))
(push (cons (caar defs)
(cons 'lambda (cddr (macroexpand
`(defmacro ,@(car defs))))))
new-env))))
;;;; BLOCK and RETURN
;;; See the explanation with the *BENV* structure definition.
(def-cg block cg-block (name &rest forms)
(let* ((end-tag (new-internal-tag))
(struct (make-benv end-tag for-value function-level nspecials))
(entry (list* '%block name struct))
(*benv* (cons entry *benv*)))
;; This might turn into the start of a catch in pass-2.
(inst-out `(%block ,struct))
;; Compile all the sub-forms as a progn.
(cg-form (cons 'progn forms) for-value)
;; Deposit the end-tag or finish the call to catch.
(inst-out `(%block1 ,end-tag ,struct))
;; If this is a non-catch frame, we might be able to leave it that way.
;; Returns see only other block and tagbody frames in the way.
;; Now must check whether any of these has turned into a catch-type.
;; If so, this frame is catch-type too.
(do ((x (benv-fixups struct) (cdr x)))
((or (benv-catch-tag struct)
(null x)))
(do ((y (car x) (cdr y)))
((eq (car y) entry))
(cond ((eq (caar y) '%block)
(when (benv-catch-tag (cddr (car y)))
(setf (benv-catch-tag struct) (new-internal-tag))
(return nil)))
((eq (caar y) '%tagbody)
(when (tenv-catch-tag (cddr (car y)))
(setf (benv-catch-tag struct) (new-internal-tag))
(return nil)))
(t (error "Bogus item on *BENV* list.")))))))
(def-cg return-from cg-return-from (name &optional (value nil))
(do ((b *benv* (cdr b))
(this-entry nil)
(garbagep nil)
(catch-garbage nil)
(struct nil)
(catch-tag nil)
(fv nil))
((null b)
(clc-error "Return to unseen block name: ~S" name))
(setq this-entry (car b))
;; Look for the target Block entry on the *BENV* list.
;; Note any garbage or catch-type frames along the way.
(cond ((eq (car this-entry) '%garbage)
(setq garbagep t))
((eq (car this-entry) '%catch-garbage)
(setq catch-garbage t))
((eq (car this-entry) '%tagbody)
(if (tenv-catch-tag (cddr this-entry))
(setq garbagep t)))
((not (eq (cadr this-entry) name))
(if (benv-catch-tag (cddr this-entry))
(setq garbagep t)))
;; OK, this is the block that matches this return.
(t (setq struct (cddr this-entry))
(setq fv (benv-for-value struct))
(cg-form value fv)
(cond ((not (= (benv-function-level struct) function-level))
;; Not even in same function, got to throw to get out.
(unless (setq catch-tag (benv-catch-tag struct))
(setq catch-tag (new-internal-tag))
(setf (benv-catch-tag struct) catch-tag))
(unless fv (inst-out '(set-null stack)))
(inst-out `(push (constant ,(make-const catch-tag))))
(inst-out '(throw stack)))
((and (eq (benv-for-value struct) 'tail)
(not catch-garbage))
;; Return in tail position can not always jump out,
;; since catch frames need to be cleaned up.
(when annotate-special-bindings
(let ((nunbind (- nspecials (benv-nspecials struct))))
(cond ((zerop nunbind))
((> nunbind most-positive-short-constant)
(inst-out
`(unbind (constant ,(make-const nunbind)))))
(t (inst-out
`(unbind (short-const ,nunbind)))))))
(inst-out `(branch ,(benv-end-tag struct))))
((or garbagep (benv-catch-tag struct))
;; We've got garbage on the stack. Got to throw out.
(unless (setq catch-tag (benv-catch-tag struct))
(setq catch-tag (new-internal-tag))
(setf (benv-catch-tag struct) catch-tag))
(unless fv (inst-out '(set-null stack)))
(inst-out `(push (constant ,(make-const catch-tag))))
(inst-out '(throw stack)))
(t
;; Frames in the way, but none are catch-type now.
;; Defer the decision until pass 2.
(inst-out `(%return ,struct ,nspecials))
(setf (benv-fixups struct)
(cons *benv* (benv-fixups struct)))))
(return nil)))))
;;; Pass-2 forms for block and return.
;;; If this block has been assigned a catch-tag, compile it as a catch header.
;;; Else, it evaporates -- everyone is just jumping to the right exit.
(def-p2 %block %block-p2 (struct)
(if (benv-catch-tag struct)
`((push (constant ,(make-const (list '**tag** (benv-end-tag struct)))))
(push (constant ,(make-const (benv-catch-tag struct))))
,(if (memq (benv-for-value struct) '(multiple tail))
`(catch-multiple stack)
`(catch stack)))
nil))
(def-p2 %block1 %block1-p2 (end-tag struct)
(if (benv-catch-tag struct)
`((push (constant ,(make-const (benv-catch-tag struct))))
(throw stack)
,end-tag
,@(unless (benv-for-value struct) '((pop ignore))))
`(,end-tag)))
(def-p2 %return %return-p2 (struct nspecials)
(if (benv-catch-tag struct)
;; If no value to throw, create one. Then throw.
`(,@(if (benv-for-value struct) nil '((set-null stack)))
(throw (constant ,(make-const (benv-catch-tag struct)))))
;; Pop specials as needed, then go to end tag.
`(,@(let ((nunbind (- nspecials (benv-nspecials struct))))
(cond ((zerop nunbind) nil)
((> nunbind most-positive-short-constant)
`((unbind (constant ,(make-const nunbind)))))
(t `((unbind (short-const ,nunbind))))))
(branch ,(benv-end-tag struct)))))
;;;; TAGBODY and GO.
;;; See the description with the *BENV* structure definition.
(def-cg tagbody cg-tagbody (&rest forms)
(let* ((tags nil)
(tagstructs nil)
(struct (make-tenv function-level nspecials 1))
(entry nil)
(*benv* *benv*)
(tag1 (new-internal-tag))
(tag2 (new-internal-tag))
(tag3 (new-internal-tag)))
;; Pre-scan to build structures for all tags in this body.
(do ((f forms (cdr f)))
((atom f))
(when (or (symbolp (car f)) (integerp (car f)))
(if (memq (car f) tags)
(clc-error "Tag ~s appears more than once in a tagbody." (car f))
(progn
(push (car f) tags)
(push (make-tag (car f) (new-internal-tag)) tagstructs)))))
(setq entry (list* '%tagbody tags struct))
(setf (tenv-tags struct) tagstructs)
(setq *benv* (cons entry *benv*))
;; This might turn into the start of a catch.
(inst-out `(%tagbody ,struct ,tag1 ,tag2 ,tag3))
;; Now compile the forms. None are for value.
(do ((f forms (cdr f)))
((atom f))
(cond ((or (symbolp (car f)) (integerp (car f)))
(dolist (ts tagstructs)
(when (eql (car f) (tag-name ts))
(inst-out (tag-internal-tag ts)))))
((atom (car f))
(clc-warning "Atom in tagbody not a legal tag: ~s" (car f)))
(t (cg-form (car f) nil))))
;; Possible end of the catch and a dispatch to the right tag.
(inst-out `(%tagbody1 ,struct ,tag1 ,tag2 ,tag3 ,for-value))
;; Complain about any unused tags.
(dolist (ts tagstructs)
(when (null (tag-usedp ts))
(clc-warning "~s unused tag in tagbody." (tag-name ts))))
;; See if any of the frames crossed by jumps to this body have become
;; catch-type frames. If so, this frame must be one also.
(do ((x (tenv-fixups struct) (cdr x)))
((or (tenv-catch-tag struct)
(null x)))
(do ((y (car x) (cdr y)))
((eq (car y) entry))
(cond ((eq (caar y) '%block)
(when (benv-catch-tag (cddr (car y)))
(setf (tenv-catch-tag struct) (new-internal-tag))
(return nil)))
((eq (caar y) '%tagbody)
(when (tenv-catch-tag (cddr (car y)))
(setf (tenv-catch-tag struct) (new-internal-tag))
(return nil)))
(t (error "Compiler bug: Bogus item on *BENV* list.")))))))
(def-cg go cg-go (tag)
(do ((b *benv* (cdr b))
(firstp t nil)
(this-entry nil)
(garbagep nil)
(catch-garbage nil)
(tstruct nil)
(struct nil)
(catch-tag nil)
(index nil))
((null b)
(clc-error "Go to unseen tag: ~S" tag))
;; Look for the right tagbody entry.
;; Note garbage on stack and catch-type frames along the way.
(setq this-entry (car b))
(cond ((eq (car this-entry) '%garbage)
(setq garbagep t))
((eq (car this-entry) '%catch-garbage)
(setq catch-garbage t))
((eq (car this-entry) '%block)
(if (benv-catch-tag (cddr this-entry))
(setq garbagep t)))
((not (member tag (the list (cadr this-entry))))
(if (tenv-catch-tag (cddr this-entry))
(setq garbagep t)))
(t (setq struct (cddr this-entry))
(setq tstruct
(dolist (ts (tenv-tags struct))
(when (eq (tag-name ts) tag) (return ts))))
(setf (tag-usedp tstruct) t)
(cond ((or garbagep
(not (= (tenv-function-level struct) function-level)))
;; Not in this function or garbage on stack. Got to throw.
(unless (setq catch-tag (tenv-catch-tag struct))
(setq catch-tag (new-internal-tag))
(setf (tenv-catch-tag struct) catch-tag))
(unless (setq index (tag-index tstruct))
(setq index (tenv-next-index struct))
(setf (tenv-next-index struct) (1+ index))
(setf (tag-index tstruct) index))
(inst-out `(push (short-const ,index)))
(inst-out `(push (constant ,(make-const catch-tag))))
(inst-out '(throw stack)))
((and firstp (not catch-garbage))
;; Nothing in the way.
;; Maybe pop some specials, then just jump to tag.
(let ((nunbind (- nspecials (tenv-nspecials struct))))
(cond ((zerop nunbind))
((> nunbind most-positive-short-constant)
(inst-out
`(unbind (constant ,(make-const nunbind)))))
(t (inst-out
`(unbind (short-const ,nunbind))))))
(inst-out `(branch ,(tag-internal-tag tstruct))))
(t
;; Other frames in the way. Defer the decision to pass 2.
(inst-out `(%go ,struct ,tstruct ,nspecials))
(setf (tenv-fixups struct)
(cons *benv* (tenv-fixups struct)))))
(return nil)))))
(def-p2 %tagbody %tagbody-p2 (struct end-tag link-tag loop-tag)
(if (tenv-catch-tag struct)
(let ((islot (make-const '%tagbody-temp%))
(skip-tag (new-internal-tag)))
;; It's a catch-type frame. Entry is index 0.
`((set-0 (special ,islot))
,loop-tag
;; Set up new catch frame.
(push (constant ,(make-const (list '**tag** end-tag))))
(push (constant ,(make-const (tenv-catch-tag struct))))
(catch stack)
;; Now dispatch on the tag value. Index is in ISLOT.
;; This code will be nicer when we get a dispatch instruction.
(push (special ,islot))
(= (short-const 0))
(branch-not-null ,skip-tag)
,@(do* ((tags (tenv-tags struct) (cdr tags))
(index nil)
(code nil))
((null tags) (nreverse code))
(when (setq index (tag-index (car tags)))
(push `(push (special ,islot)) code)
(push `(= (short-const ,index)) code)
(push `(branch-not-null ,(tag-internal-tag (car tags))) code)))
,skip-tag))
nil))
(def-p2 %tagbody1 %tagbody1-p2 (struct end-tag link-tag loop-tag for-value)
(if (tenv-catch-tag struct)
;; Fallthrough is like a throw with value NIL.
`((set-null stack)
;; Finish the catch.
(push (constant ,(make-const (tenv-catch-tag struct))))
(throw stack)
,end-tag
;; Index is now on stack. If nil, drop through, else jump
;; to loop-tag.
(copy stack)
(branch-not-null ,loop-tag)
,@(if (not for-value) '((pop ignore)) nil))
;; Not catch type. Just return NIL on fall-through.
(if for-value `((set-null stack)) nil)))
(def-p2 %go %go-p2 (struct tstruct nspecials)
(cond ((tenv-catch-tag struct)
;; There's a catch-type frame in the way. This must be a throw.
(let (index)
;; Get the tag's throw index, assinging one if needed.
(unless (setq index (tag-index tstruct))
(setq index (tenv-next-index struct))
(setf (tenv-next-index struct) (1+ index))
(setf (tag-index tstruct) index))
`((push (short-const ,index))
(throw (constant ,(make-const (tenv-catch-tag struct)))))))
(t
;; Maybe unbind specials, then just jump to the internal tag.
`(,@(let ((nunbind (- nspecials (tenv-nspecials struct))))
(cond ((zerop nunbind) nil)
((> nunbind most-positive-short-constant)
`((unbind (constant ,(make-const nunbind)))))
(t `((unbind (short-const ,nunbind))))))
(branch ,(tag-internal-tag tstruct))))))
;;;; CONTROL STRUCTURE
(def-cg the cg-the (type value)
(cg-form value
for-value
(subtypep type 'fixnum)))
(def-cg apply cg-apply (fn form1 &rest forms)
;; Had to split off form1 to get arg count right.
(setq forms (cons form1 forms))
(let ((tag (new-internal-tag)))
(cg-form fn t)
(if (or (eq for-value 'multiple)
(eq for-value 'tail))
(inst-out `(call-multiple stack (return-address ,tag)))
(inst-out `(call stack (return-address ,tag))))
(dolist (f forms) (cg-form f t))
(inst-out '(spread stack))
(inst-out `(push-last stack
(return-tag ,tag)
,@(if (and (consp fn)
(eq (car fn) 'function)
(consp (cdr fn))
(symbolp (cadr fn)))
`((function ,(cadr fn))))
(nargs ,(length forms) t)))
;; In general we can't tell how many values this might return.
(if (eq for-value 'tail) (setq returns-single-value nil))
(if (not for-value)
(inst-out `(pop ignore)))))
(def-cg funcall cg-funcall (fn &rest forms)
(let ((tag (new-internal-tag)))
(cg-form fn t)
(if (or (eq for-value 'multiple)
(eq for-value 'tail))
(inst-out `(call-multiple stack (return-address ,tag)))
(inst-out `(call stack (return-address ,tag))))
(dolist (f forms) (cg-form f t))
(inst-out `(push-last stack
(return-tag ,tag)
,@(if (and (consp fn)
(eq (car fn) 'function)
(consp (cdr fn))
(symbolp (cadr fn)))
`((function ,(cadr fn))))
(nargs ,(length forms) t)))
;; In general we can't tell how many values this might return.
(if (eq for-value 'tail) (setq returns-single-value nil))
(if (not for-value)
(inst-out `(pop ignore)))))
(def-cg progn cg-progn (&rest forms)
(cg-progn-body forms))
(defun cg-progn-body (forms)
(if (atom forms)
(cg-form nil for-value)
(do ((f forms (cdr f)))
((atom (cdr f))
(cg-form (car f) for-value))
(cg-form (car f) nil))))
(def-cg prog1 cg-prog1 (form1 &rest forms)
(cg-form form1 t)
(dolist (f forms) (cg-form f nil)))
(def-cg prog2 cg-prog2 (form1 form2 &rest forms)
(cg-form form1 nil)
(cg-form form2 t)
(dolist (f forms) (cg-form f nil)))
(def-cg multiple-value-prog1 cg-mvprog1 (form1 &rest forms)
(cg-form form1 for-value)
(dolist (f forms) (cg-form f nil)))
(def-cg multiple-value-list cg-multiple-value-list (form)
(cg-form form 'multiple)
(inst-out '(force-values stack))
(inst-out '(values-to-n stack))
(if for-value
(inst-out '(list stack))
(inst-out '(npop stack))))
(def-cg multiple-value-call cg-multiple-value-call (fn &rest forms)
(let ((tag (new-internal-tag)))
(cg-form fn t)
(if (or (eq for-value 'tail)
(eq for-value 'multiple))
(inst-out `(call-multiple stack (return-address ,tag)))
(inst-out `(call stack (return-address ,tag))))
(dolist (f forms)
(cg-form f 'multiple)
(inst-out '(flush-values stack)))
(inst-out `(push-last stack (return-tag ,tag)))
;; In general we can't tell how many values this might return.
(if (eq for-value 'tail) (setq returns-single-value nil))
(unless for-value (inst-out '(pop ignore)))))
;;; The THROW code generator assumes that it is OK to compile the second
;;; arg first. A transform makes sure this is true.
(def-cg throw cg-throw (tag value)
(cg-form value 'multiple)
(cg-form tag t)
(inst-out '(throw stack)))
;;; The CATCH code generator assumes that it is OK to reference the tag
;;; twice. A transform makes sure this is true.
(def-cg catch cg-catch (tag &rest forms)
(let ((tag1 (new-internal-tag)))
(cg-form `(quote (**tag** ,tag1)) t)
(cg-form tag t)
(if (or (eq for-value 'multiple)
(eq for-value 'tail))
(inst-out '(catch-multiple stack))
(inst-out '(catch stack)))
(let ((*benv* (list* '(%catch-garbage) '(%garbage) *benv*)))
;; We can't let guys get out by returning, so mash TAIL calls into MV.
(cg-form `(progn ,@forms)
(if (eq for-value 'tail)
'multiple
for-value))
(cg-form tag t)
(inst-out '(throw stack)))
(inst-out tag1)
(if (eq for-value 'tail) (setq returns-single-value nil))
(or for-value (inst-out `(pop ignore)))))
;;; All Catch-All frames accept multiple values, because multiple values
;;; might be thrown through them.
(def-cg unwind-protect cg-unwind-protect (pform &rest forms)
(let ((tag1 (new-internal-tag))
(tag2 (new-internal-tag)))
(cg-form '(%sp-bind %catch-all-object '%sp-internal-throw-tag) nil)
(cg-form `(quote (**tag** ,tag1)) t)
(inst-out '(catch-all stack))
(let ((*benv* (list* '(%catch-garbage) '(%garbage) *benv*)))
(cg-form pform for-value)
(cg-form '%catch-all-object (or for-value t))
(inst-out '(throw stack))
(inst-out tag1)
(cg-form `(progn ,@forms) nil)
(cg-form '%catch-all-object t)
(cg-form '%sp-internal-throw-tag t)
(inst-out '(eq stack))
(inst-out `(branch-not-null ,tag2))
(cg-form '%sp-internal-throw-tag t)
(inst-out '(unbind (short-const 1)))
(inst-out '(throw stack)))
(inst-out tag2)
(inst-out '(unbind (short-const 1)))
(or for-value (inst-out '(pop ignore)))))
;;; Complain about misplaced declarations.
(def-cg declare cg-declare (&rest args)
(declare (ignore args))
(clc-warning "Misplaced DECLARE form. Ignoring it.")
nil)
;;;; CONDITIONALS
;;; BR-NULL compiles code to eval and test the predicate form, and to
;;; branch to DEST if the result is NIL. The value of the predicate is
;;; popped and discarded in any case.
(defun br-null (pred dest)
(let ((for-value 'predicate))
(setq pred (transform pred)))
(cond ((and (not (atom pred))
(eq (car pred) 'not))
(br-not-null (cadr pred) dest))
((or (null pred) (equal pred '(quote nil)))
(inst-out `(branch ,dest)))
((constantp pred) nil)
((atom pred)
(cg-form pred 'predicate)
(inst-out `(branch-null ,dest)))
((eq (car pred) 'and)
(do ((p (cdr pred) (cdr p)))
((null p))
(br-null (car p) dest)))
((eq (car pred) 'or)
(do ((p (cdr pred) (cdr p))
(tag (new-internal-tag)))
((null p)
(inst-out `(branch ,dest))
(inst-out tag))
(br-not-null (car p) tag)))
(t (cg-form pred 'predicate)
(inst-out `(branch-null ,dest)))))
;;; BR-NOT-NULL compiles code to eval and test the predicate form, and to
;;; branch to DEST if the result is not NIL. The value of the predicate is
;;; popped and discarded in any case.
(defun br-not-null (pred dest)
(let ((for-value 'predicate))
(setq pred (transform pred)))
(cond ((and (not (atom pred))
(eq (car pred) 'not))
(br-null (cadr pred) dest))
((or (null pred) (equal pred '(quote nil))) nil)
((constantp pred)
(inst-out `(branch ,dest)))
((atom pred)
(cg-form pred 'predicate)
(inst-out `(branch-not-null ,dest)))
((eq (car pred) 'or)
(do ((p (cdr pred) (cdr p)))
((null p))
(br-not-null (car p) dest)))
((eq (car pred) 'and)
(do ((p (cdr pred) (cdr p))
(tag (new-internal-tag)))
((null p)
(inst-out `(branch ,dest))
(inst-out tag))
(br-null (car p) tag)))
(t (cg-form pred 'predicate)
(inst-out `(branch-not-null ,dest)))))
;;; BR-SAVE-NOT-NULL compiles code to eval and test the predicate form, and to
;;; branch to DEST if the result is not NIL. If the branch is taken, the
;;; non-null value is left on the stack.
(defun br-save-not-null (pred dest)
(let ((for-value t))
(setq pred (transform pred)))
(cond ((or (null pred) (equal pred '(quote nil))) nil)
((constantp pred)
(cg-form pred t)
(inst-out `(branch ,dest)))
((and (listp pred) (eq (car pred) 'or))
(do ((p (cdr pred) (cdr p)))
((null p))
(br-save-not-null (car p) dest)))
(t (cg-form pred t)
(inst-out `(branch-save-not-null ,dest)))))
(def-cg and cg-and (&rest forms)
(cond ((atom forms)
(cg-form t for-value))
(for-value
(do ((f forms (cdr f))
(tag1 (new-internal-tag))
(tag2 (new-internal-tag)))
((atom (cdr f))
(cg-form (car f) for-value)
(inst-out `(branch ,tag2))
(inst-out tag1)
(inst-out `(set-null stack))
(inst-out tag2))
(br-null (car f) tag1)))
(t (do ((f forms (cdr f))
(tag (new-internal-tag)))
((atom (cdr f))
(cg-form (car f) nil)
(inst-out tag))
(br-null (car f) tag)))))
(def-cg or cg-or (&rest forms)
(cond ((atom forms)
(cg-form nil for-value))
(for-value
(do ((f forms (cdr f))
(tag (new-internal-tag)))
((atom (cdr f))
(cg-form (car f) for-value)
(inst-out tag))
(br-save-not-null (car f) tag)))
(t (do ((f forms (cdr f))
(tag (new-internal-tag)))
((atom (cdr f))
(cg-form (car f) nil)
(inst-out tag))
(br-not-null (car f) tag)))))
(def-cg if cg-if (pred then &optional (else nil))
(let ((tag1 (new-internal-tag))
(tag2 (new-internal-tag)))
(br-null pred tag1)
(cg-form then for-value)
(inst-out `(branch ,tag2))
(inst-out tag1)
(cg-form else for-value)
(inst-out tag2)))
(def-cg not cg-not (arg)
(cg-form arg 'predicate)
(inst-out '(not-predicate stack)))
(def-cg cond cg-cond (&rest forms)
(let ((endtag (new-internal-tag)))
(do ((clauses forms (cdr clauses))
(clause)
(next-tag))
((atom clauses))
(setq clause (car clauses))
(cond ((atom clause)
(clc-error "Atomic clause in Cond: ~S" clause))
;; Normal clause.
((cdr clause)
(setq next-tag (new-internal-tag))
(br-null (car clause) next-tag)
(cg-form (cons 'progn (cdr clause)) for-value)
(inst-out `(branch ,endtag))
(inst-out next-tag))
;; Singleton clause for value.
(for-value (br-save-not-null (car clause) endtag))
;; Singleton clause not for value.
(t (br-not-null (car clause) endtag))))
;; In case we fell through last clause, return NIL.
;; Peeper will flush this code if we cannot get here.
(cg-form nil for-value)
(inst-out endtag)))
;;;; BASIC FUNCTIONS
;;; Normal data-bashing operations that do not turn into misc-ops.
;;; These two-arg predicates turn directly into byte codes.
;;; More complex predicates are turned into these forms by transforms.
(defun two-arg-predicate (form)
(let ((annotation nil))
(when (and *number-type-annotations* (memq (car form) '(= > < )))
(setq annotation `((type ,(find-type (cadr form))
,(find-type (caddr form))))))
(cg-form (cadr form) t)
(cg-form (caddr form) t)
(inst-out `(,(car form) stack ,@annotation))))
(setf (get 'eq 'cg) 'two-arg-predicate)
(setf (get 'eql 'cg) 'two-arg-predicate)
(setf (get '= 'cg) 'two-arg-predicate)
(setf (get '> 'cg) 'two-arg-predicate)
(setf (get '< 'cg) 'two-arg-predicate)
(defun two-arg-arith (form)
(let ((annotation nil))
(when *number-type-annotations*
(setq annotation `((type ,(or *all-integers-are-fixnums*
fixnum-output)
,(find-type (cadr form))
,(find-type (caddr form))))))
(cg-form (cadr form) t)
(cg-form (caddr form) t)
(inst-out `(,(car form) stack ,@annotation))))
(setf (get '+ 'cg) 'two-arg-arith)
(setf (get '- 'cg) 'two-arg-arith)
(setf (get '* 'cg) 'two-arg-arith)
(setf (get '/ 'cg) 'two-arg-arith)
;;; The following assume that all C...R forms have been expanded into
;;; CAR/CDR forms.
(def-cg car cg-car (arg)
(cond ((and (not (atom arg))
(not (atom (cdr arg)))
(eq (car arg) 'car))
(cg-form (cadr arg) t)
(inst-out `(caar stack ,@(when *never-check-car-cdr* '((no-check))))))
((and (not (atom arg))
(not (atom (cdr arg)))
(eq (car arg) 'cdr))
(cg-form (cadr arg) t)
(inst-out `(cadr stack ,@(when *never-check-car-cdr* '((no-check))))))
(t (cg-form arg t)
(inst-out `(car stack ,@(when (or *never-check-car-cdr*
(and (not *cdr-check-enable*)
(subtypep (find-type arg)
'list)))
'((no-check))))))))
(def-cg cdr cg-cdr (arg)
(cond ((and (not (atom arg))
(not (atom (cdr arg)))
(eq (car arg) 'car))
(cg-form (cadr arg) t)
(inst-out `(cdar stack ,@(when *never-check-car-cdr* '((no-check))))))
((and (not (atom arg))
(not (atom (cdr arg)))
(eq (car arg) 'cdr))
(cg-form (cadr arg) t)
(inst-out `(cddr stack ,@(when *never-check-car-cdr* '((no-check))))))
(t (cg-form arg t)
(inst-out `(cdr stack ,@(when (or *never-check-car-cdr*
(and (not *cdr-check-enable*)
(subtypep (find-type arg)
'list)))
'((no-check))))))))
(def-cg list cg-list (&rest args)
(if (null args)
(inst-out '(set-null stack))
(let ((n (length args)))
(cg-form (car args) t)
(let ((*benv* (cons '(%garbage) *benv*)))
(dolist (a (cdr args)) (cg-form a t)))
(cg-form n t)
(inst-out '(list stack)))))
(def-cg vector cg-vector (&rest args)
(let ((n (length args)))
(dolist (a args) (cg-form a t))
(cg-form n t)
(inst-out '(vector stack))))
(def-cg list* cg-list* (&rest args)
(if (null (cdr args))
(cg-form (car args) t)
(let ((n (1- (length args))))
(cg-form (car args) t)
(let ((*benv* (cons '(%garbage) *benv*)))
(dolist (a (cdr args)) (cg-form a t)))
(cg-form n t)
(inst-out '(list* stack)))))
(def-cg 1+ cg-1+ (arg)
(let ((annotation nil))
(when *number-type-annotations*
(setq annotation `((type ,(or *all-integers-are-fixnums*
fixnum-output)
,(find-type arg)))))
(cg-form arg t)
(inst-out `(1+ stack ,@annotation))))
(def-cg 1- cg-1- (arg)
(let ((annotation nil))
(when *number-type-annotations*
(setq annotation `((type ,(or *all-integers-are-fixnums*
fixnum-output)
,(find-type arg)))))
(cg-form arg t)
(inst-out `(1- stack ,@annotation))))
;;; Handles two-arg form only.
(def-cg truncate cg-truncate (x y)
(cg-form x t)
(cg-form y t)
(inst-out '(truncate stack))
(unless (or (eq for-value 'multiple) (eq for-value 'tail))
(inst-out '(npop (short-const 2))))
(if (eq for-value 'tail) (setq returns-single-value nil)))
(def-cg rem cg-rem (x y)
(cg-form x t)
(cg-form y t)
(inst-out '(truncate stack))
(inst-out '(pop ignore))
(inst-out '(exchange stack))
(inst-out '(pop ignore)))
(def-cg logior cg-logior (x y)
(cg-form x t)
(cg-form y t)
(inst-out '(logior stack)))
(def-cg logand cg-logand (x y)
(cg-form x t)
(cg-form y t)
(inst-out '(logand stack)))
(def-cg logxor cg-logxor (x y)
(cg-form x t)
(cg-form y t)
(inst-out '(logxor stack)))
(def-cg lognot cg-lognot (x)
(cg-form x t)
(inst-out '(lognot stack)))
(def-cg %sp-decode-float cg-%sp-decode-float (x)
(cg-form x t)
(inst-out '(decode-float stack))
(unless (or (eq for-value 'tail) (eq for-value 'multiple))
(inst-out '(npop (short-const 3))))
(if (eq for-value 'tail) (setq returns-single-value nil)))
;;;; SUB-PRIMTIVES
;;; The following are used in the evaluator and are generated by certain
;;; transforms. Not for casual use.
;;; Processor for %SP-BIND.
;;; (%SP-BIND value var) binds VAR to VALUE, returns NIL. Note odd order of
;;; arguments to this function. If this is called, the UNCERTAIN-NSPECIALS
;;; flag is set, since we can't be sure how many top-level bindings there
;;; will be.
(def-cg %sp-bind cg-%sp-bind (value var)
(setq uncertain-nspecials t)
(cg-form value t)
(cg-form var t)
(inst-out '(bind stack))
(if for-value (inst-out '(set-null stack))))
(def-cg %sp-unbind cg-%sp-unbind (x)
(cg-form x t)
(inst-out '(unbind stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-npop cg-%sp-npop (x)
(cg-form x t)
(inst-out '(npop stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-spread cg-%sp-spread (x)
(cg-form x t)
(inst-out '(spread stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-call cg-%sp-call (x)
(cg-form x t)
(inst-out '(call-multiple stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-push cg-%sp-push (x)
(cg-form x t)
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-bind-t cg-%sp-bind-t (x)
(cg-form x t)
(inst-out '(set-t stack))
(inst-out '(bind stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-bind-null cg-%sp-bind-null (x)
(cg-form x t)
(inst-out '(bind-null stack))
(when for-value (inst-out '(set-null stack))))
(def-cg %sp-start-call cg-%sp-start-call ()
(inst-out '(push-last stack)))
;;; If called for value, %SP-POP just does nothing, but claims to have
;;; pushed a value on the stack. This has the effect of popping one item
;;; and returning it.
(def-cg %sp-pop cg-%sp-pop ()
(if for-value
nil
(inst-out '(pop ignore))))
;;; %SP-RETURN-FROM is used to return from some frame other than the
;;; current one. First arg is the value (maybe multiple), second arg
;;; is the target frame.
(def-cg %sp-return-from cg-%sp-return-from (value frame)
(cg-form value 'tail)
(cg-form frame t)
(inst-out '(set-call-frame stack))
(inst-out '(return stack (special-bindings nil))))
;;;; CONVERSION FOR INLINE LAMBDAS.
;;; LAMBDA-TO-LET takes an arbitrary lambda-list and a list of argument
;;; forms and returns a let-list that does the equivalent bindings.
;;; Copes with &optional, &rest, and &aux. Does not hack &key, as forms
;;; containing &key cannot always be turned into simple Let forms.
(defun lambda-to-let (lambda-list argument-list)
(do ((ll lambda-list (cdr ll))
(al argument-list (cdr al))
(let-list nil))
((atom ll)
(cond ((null al)
(nreverse let-list))
(t (clc-error "Too many args supplied to Lambda form.")
(nreverse let-list))))
(case (car ll)
(&optional (return (lambda-to-let-optional (cdr ll) al let-list)))
(&rest (return (lambda-to-let-rest (cdr ll) al let-list)))
(&aux (cond ((null al)
(return (nconc (nreverse let-list) (cdr ll))))
(t (clc-error "Too many args supplied to Lambda form.")
(return (nreverse let-list)))))
((&key &allow-other-keys)
(clc-error "Stray ~S in Lambda list." (car ll))
(return (nreverse let-list))))
(cond ((atom al)
(clc-error "Too few args supplied to Lambda form.")
(return (nreverse let-list)))
(t (push (list (car ll) (car al)) let-list)))))
(defun lambda-to-let-optional (lambda-list argument-list let-list)
(do ((ll lambda-list (cdr ll))
(al argument-list)
var)
((atom ll)
(cond ((null al)
(nreverse let-list))
(t (clc-error "Too many args supplied to Lambda form.")
(nreverse let-list))))
(setq var (car ll))
(case var
(&rest (return (lambda-to-let-rest (cdr ll) al let-list)))
(&aux (cond ((null al)
(return (nconc (nreverse let-list) (cdr ll))))
(t (clc-error "Too many args supplied to Lambda form.")
(nreverse let-list))))
((&optional &key &allow-other-keys)
(clc-error "Stray ~S in Lambda list." var)
(return (nreverse let-list)))
(t (cond ((atom al)
;; No more args, use default.
(cond ((atom var)
(push (list var nil) let-list))
(t (push (list (car var) (cadr var)) let-list)
;; Supplied-p var, if any, is nil.
(if (consp (cddr var))
(push (list (caddr var) nil) let-list)))))
;; We do have more args, so use them.
(t (cond ((atom var)
(push (list var (car al)) let-list))
(t (push (list (car var) (car al)) let-list)
;; Supplied-p var, if any, is T.
(if (consp (cddr var))
(push (list (caddr var) t) let-list))))
(setq al (cdr al))))))))
(defun lambda-to-let-rest (lambda-list argument-list let-list)
(cond ((not (symbolp (car lambda-list)))
(clc-error "Ill formed &rest arg in Lambda list.")
(nreverse let-list))
(t (push (if (atom argument-list)
(list (car lambda-list) nil)
(list (car lambda-list) (cons 'list argument-list)))
let-list)
(cond ((atom (cdr lambda-list))
(nreverse let-list))
((eq (cadr lambda-list) '&aux)
(nconc (nreverse let-list) (cddr lambda-list)))
(t (clc-error "Ill-formed lambda list."))))))
(defstruct binding
"Used by optimize-let-bindings to decide which bindings it can optimize out."
(possible t)
name
refs-in-rhs)
;;; Takes a list of binding structures and returns all the variables bound
;;; and referenced as a list.
(defun vars-in-bindings (possibles)
(let ((vars '()))
(dolist (x possibles)
(pushnew (binding-name x) vars)
(dolist (x (binding-refs-in-rhs x))
(pushnew (car x) vars)))
vars))
;;; Takes a list of binding structures and the variables which are set in
;;; the body. Unsets the structure's possible field if either the lhs or
;;; one of the things on the rhs is in the list of things set.
(defun prune-possibles (possibles set)
(dolist (s set)
(dolist (p possibles)
(if (or (eq s (binding-name p))
(member s (binding-refs-in-rhs p) :key #'car))
(setf (binding-possible p) nil))))
possibles)
;;; This takes the bindings for a let* and goes down them constructing a
;;; binding structure for each binding that is a candidate to be removed.
(defun examine-let-bindings (bindings let*p)
(let ((possibles '()))
(dolist (b bindings)
(cond ((symbolp b) (push (make-binding :name b) possibles))
((not (cdr b)) (push (make-binding :name (car b)) possibles))
(let*p
(multiple-value-bind (s r m) (sf-analyze-list (cdr b))
;; If someone inside punted, any variable could be reffed, so we
;; punt too.
(when (eq t m) (return-from examine-let-bindings nil))
(let ((set (nconc (mapcar #'car s) m)))
;; If we just set one of the variables used in a binding
;; above, that binding is no longer eligible.
(setq possibles (prune-possibles possibles set))
(push (make-binding :name (car b) :refs-in-rhs r
:possible (side-effect-free-p (cadr b)))
possibles))))
(t
(multiple-value-bind (s r m) (sf-analyze-list (cdr b))
(declare (ignore s m))
(push (make-binding :name (car b) :refs-in-rhs r
:possible (side-effect-free-p (cadr b)))
possibles))))
;; Specials can never be optimized.
(let ((p (car possibles)))
(if (or (special-reference-p (binding-name p))
(dolist (x (binding-refs-in-rhs p) nil)
(if (special-reference-p (car x)) (return t))))
(setf (binding-possible p) nil))))
possibles))
;;; Given a let or let* form, analyze the body for sets/references of the
;;; variables that the let or let* binds. If a variable is/might-be set
;;; within the let, leave it. Otherwise, if it is bound to something
;;; simple, or bound to something side-effect free and used only once, or
;;; unused, replace the references by what the variable is bound to and
;;; delete the binding. In order that this work correctly for let*, we
;;; look through the bindings in reverse order and delete each name from the
;;; list of those eligible to be optimized out after we see it once. Thus
;;; if we have the same variable name used twice the binding that is seen
;;; is the one that we replace with.
(defun optimize-let-bindings (bindings body let*p)
(if *optimize-let-bindings*
(let* ((bindings (copy-tree bindings))
(possibles (examine-let-bindings bindings let*p))
(body (copy-tree body))
(vars (vars-in-bindings possibles))
reffed)
;; Possibles may be nil, signalling to examine-let-bindings saw a
;; form it couldn't analyze and punted, or we have (let nil ...).
(unless possibles
(return-from optimize-let-bindings (values bindings body)))
(multiple-value-bind (s r m) (sf-analyze-list body vars)
(let ((set (nconc (mapcar #'car s) m)))
(setq reffed r)
(setq possibles (prune-possibles possibles set))))
(setq bindings (nreverse bindings))
;; Look down the binding list backwards, starting with only the
;; information for the body. In a let*, we add information as we go.
(do ((rest possibles (cdr rest))
(b bindings (cdr b)))
((null b) (values (delete nil (nreverse bindings)) body))
(let* ((x (car rest))
(name (binding-name x))
(bound-to (if (listp (car b)) (cadr (car b)) nil))
(nrefs (if name (count name reffed :key #'car))))
;; If it is still possible (and thus side effect free), and either
;; trivial* or referenced once, then delete the binding (nils are
;; removed from bindings at end). Substitute in all the refs, and
;; cut them out of the reffed list (or the rplacad forms will still
;; be there...). For let* add any more references in the rhs.
(when (and (binding-possible x)
(or (trivial*p bound-to) (<= nrefs 1)))
(rplaca b nil)
(do* ((ref reffed (cdr ref))
(r (car ref) (car ref)))
((atom ref))
(when (eq name (car r))
;; Substitute it in, and remove it from the reffed list.
(rplaca r bound-to)
(rplaca ref nil)
(when let*p
(setq vars (delete name vars))
(multiple-value-bind (s r m) (sf-analyze-list r vars)
(declare (ignore s m))
(setq reffed (nconc r reffed)))))))
;; Stop considering the current variable (there's a problem with
;; getting the pointers right if you optimize out two vars with
;; the same name, I think). Add references to things in the rhs
;; and note any sets that go on in the rhs.
(setq vars (delete name vars))
(when (and let*p (listp (car b)) (cdr (car b)))
(multiple-value-bind (s r m) (sf-analyze-list (cdr (car b)) vars)
(prune-possibles possibles m)
(prune-possibles possibles (mapcar #'car s))
(setq reffed (nconc r reffed)))))))
(values bindings body)))
;;;
;;; Functions to examine special forms for which variables are set and
;;; referenced in the Spice Lisp compiler.
;;;
;;;
;;;
(defvar *sf-input-vars* ()
"The value of vars passed to sf-analyze-mumble. Maybe changed as we
pass the analysis down past bindings, but without hair this is what we
want to throw when we see an impenetrable form.")
;;; Vars is either a list of vars to look at or a list whose car is t and whose
;;; cdr is a list of vars not to look at.
;;; Both of these eval their args more than once.
(defmacro delete-from-vars (x vars)
`(if (eq t (car ,vars))
(push ,x (cdr ,vars))
(setq ,vars (delete ,x ,vars))))
(defmacro add-to-vars (x vars)
`(if (eq t (car ,vars))
(setq ,vars (cons t (delete ,x (cdr ,vars))))
(push ,x ,vars)))
(defmacro member-vars (x vars)
`(if (eq t (car ,vars))
(not (member ,x (cdr ,vars)))
(member ,x ,vars)))
;;; Sf-analyze-list is calls on a list of forms and some variables to tell
;;; which are affected (in the form above, where t has special meaning).
;;; It returns either pointers to the variables set, those referenced, and
;;; nil; or two nils and the list of input vars (not pointers). The latter
;;; indicates that any variable might be set or referenced. This is because
;;; the analyzed form contains a defun, eval-when, compiler-let, macrolet,
;;; or progv.
(defun sf-analyze-list (forms &optional (vars '(t)))
(catch 'sf-analyze
(let* ((*sf-input-vars* vars))
(cond ((or (null forms) (null vars)) (throw 'sf-analyze (values () () ())))
((symbolp forms)
(error "Compiler bug: sf analyzer called directly on a symbol."))
(t
(multiple-value-bind (set reffed) (sf-over-list forms vars)
(values set reffed '())))))))
;;; This macroexpands the form first using the macros in the compiler, then
;;; the normal macros.
(defun exhaustively-macroexpand (form)
(do ((expansion))
(nil)
(setq expansion (if (symbolp (car form)) (get (car form) 'macro-in-compiler)))
(if expansion
(setq form (funcall expansion form))
(return nil)))
(macroexpand form))
;;; This is only called by sf-over-list-or-tagbody. This is also the only
;;; place where we actually find a variable which is reffed.
;;; Look at a form for sets/refs. If it is a variable, assume it is a ref.
;;; If it is a list, assume it is a function call (or special form).
(defun sf-over-form (un-car-form vars)
(let ((form (car un-car-form)))
(cond ((null vars) (values () ()))
((symbolp form)
(values () (if (member-vars form vars) (list un-car-form) ())))
((listp form)
(rplaca un-car-form (copy-tree (exhaustively-macroexpand form)))
(setq form (car un-car-form))
(if (special-form-p (car form))
(funcall (get (car form) 'sf-analyzer) form vars)
(sf-over-list (cdr form) vars)))
(t (values () ())))))
(defmacro sf-over-list-or-tagbody (tagbodyp)
`(let ((set '())
(reffed '()))
(do ((un-car-form forms (cdr un-car-form)))
((null un-car-form))
(when ,(if tagbodyp '(listp forms) t)
(multiple-value-bind (s r) (sf-over-form un-car-form vars)
(setq set (nconc s set))
(setq reffed (nconc r reffed)))))
(values set reffed)))
;;; Look over each element in the list with sf-over-form.
(defun sf-over-list (forms vars) (sf-over-list-or-tagbody nil))
;;; Like sf-over-list, but ignore any top-level atoms.
(defun sf-over-tagbody (forms vars) (sf-over-list-or-tagbody t))
;;; Define the sf function and put it on the property list of the form.
(defmacro defsf (sf fn &rest body)
`(progn
(setf (get ',sf 'sf-analyzer) ',fn)
(defun ,fn (form vars) ,@body)))
;;; Here are the two places where variables actually get found to be listed as set.
(defun sf-setq (form vars)
(do ((f (cdr form) (cddr f))
(reffed '())
(set '()))
((null f) (values set reffed))
(if (member-vars (car f) vars) (pushnew f set))
(multiple-value-bind (s r) (sf-over-form (cdr f) vars)
(setq set (nconc s set))
(setq reffed (nconc r reffed)))))
(setf (get 'setq 'sf-analyzer) 'sf-setq)
(setf (get 'psetq 'sf-analyzer) 'sf-setq)
(defsf multiple-value-setq sf-multiple-value-setq
(multiple-value-bind (set reffed) (sf-over-list (cddr form) vars)
(do ((x (cadr form) (cdr x)))
((null x))
(if (member-vars (car x) vars) (pushnew x set)))
(values set reffed)))
;;; Blow these off, if you use these you lose on these optimizations
(setf (get 'defun 'sf-analyzer) 'sf-punt)
(setf (get 'eval-when 'sf-analyzer) 'sf-punt)
(setf (get 'compiler-let 'sf-analyzer) 'sf-punt)
(setf (get 'macrolet 'sf-analyzer) 'sf-punt)
(setf (get 'progv 'sf-analyzer) 'sf-punt)
(defun sf-punt (form vars)
(declare (ignore form vars))
(throw 'sf-analyze (values '() '() *sf-input-vars*)))
;;; These all suffer from not knowing if all the forms are evaluated, which
;;; variables might be shadowed, etc., but they still come up with something.
(defsf and sf-and (sf-over-list (cdr form) vars))
(defsf or sf-or (sf-over-list (cdr form) vars))
(defsf if sf-if (sf-over-list (cdr form) vars))
(defsf cond sf-cond
(let ((set '())
(reffed '()))
(dolist (branch (cdr form))
(multiple-value-bind (s r) (sf-over-list branch vars)
(setq set (nconc s set))
(setq reffed (nconc r reffed))))
(values set reffed)))
(defsf prog sf-prog (sf-over-list (cdr form) vars))
(defsf prog1 sf-prog1 (sf-over-list (cdr form) vars))
(defsf prog2 sf-prog2 (sf-over-list (cdr form) vars))
(defsf progn sf-progn (sf-over-list (cdr form) vars))
(defsf block sf-block (sf-over-list (cddr form) vars))
(defsf return sf-return (sf-over-list (cdr form) vars))
(defsf return-from sf-return-from (sf-over-list (cddr form) vars))
(defsf flet sf-flet (sf-over-list (cddr form) vars))
(defsf labels sf-labels (sf-over-list (cddr form) vars))
(defsf catch sf-catch (sf-over-list (cdr form) vars))
(defsf unwind-protect sf-unwind-protect (sf-over-list (cdr form) vars))
(defsf throw sf-throw (sf-over-list (cdr form) vars))
(defsf the sf-the (sf-over-list (cddr form) vars))
(defsf multiple-value-list sf-multiple-value-list
(sf-over-list (cdr form) vars))
(defsf multiple-value-call sf-multiple-value-call
(sf-over-list (cdr form) vars))
(defsf multiple-value-prog1 sf-multiple-value-prog1
(sf-over-list (cdr form) vars))
(defsf declare sf-declare (declare (ignore form vars)) (values () ()))
(defsf quote sf-quote (declare (ignore form vars)) (values () ()))
(defsf function sf-function (declare (ignore form vars)) (values () ()))
(defsf go sf-go (declare (ignore form vars)) (values () ()))
(defsf tagbody sf-tagbody (sf-over-tagbody (cdr form) vars))
;;; Look at the binding form. Then bind the variables (which means making a copy
;;; of the vars and deleting from it) and look at the body.
(defsf multiple-value-bind sf-multiple-value-bind
(let ((vars (copy-list vars))
set
reffed)
(multiple-value-setq (set reffed) (sf-over-form (cddr form) vars))
(dolist (x (cadr form)) (delete-from-vars x vars))
(multiple-value-bind (s r) (sf-over-list (cdddr form) vars)
(values (nconc s set) (nconc r reffed)))))
;;; Look for sets/refs in the initforms. Bind the variables so that in the
;;; body sets/refs to those names don't count. Look in the body.
(defmacro defsf-prog-let (sf fn over-fn)
`(defsf ,sf ,fn
(let ((vars (copy-list vars))
(set '())
(reffed '()))
(dolist (binding (cadr form))
(if (listp binding)
(multiple-value-bind (s r) (sf-over-list (cdr binding) vars)
(setq set (nconc s set))
(setq reffed (nconc r reffed)))))
(dolist (binding (cadr form))
(setq vars (delete-from-vars
(if (symbolp binding) binding (car binding))
vars)))
(multiple-value-bind (s r) (,over-fn (cddr form) vars)
(values (nconc s set) (nconc r reffed))))))
;;; Look for sets/refs in each initform, then immediately bind the variable
;;; so that future sets/refs to that var name don't count. Finally look at
;;; the body.
(defmacro defsf-prog*-let* (sf fn over-fn)
`(defsf ,sf ,fn
(let ((vars (copy-list vars))
(set '())
(reffed '()))
(dolist (binding (cadr form))
(cond ((listp binding)
(multiple-value-bind (s r) (sf-over-list (cdr binding) vars)
(setq set (nconc s set))
(setq reffed (nconc r reffed)))
(setq vars (delete-from-vars (car binding) vars)))
(t (setq vars (delete-from-vars binding vars)))))
(multiple-value-bind (s r) (,over-fn (cddr form) vars)
(values (nconc s set) (nconc r reffed))))))
(defsf-prog-let prog sf-prog sf-over-tagbody)
(defsf-prog-let let sf-let sf-over-list)
(defsf-prog*-let* prog* sf-prog* sf-over-tagbody)
(defsf-prog*-let* let* sf-let* sf-over-list)
(proclaim '(inline function-min-args function-max-args function-rest-arg-p))
;;; The minimum number of args of a function object.
(defun function-min-args (fn)
(cond ((compiled-function-p fn)
(ldb %function-min-args-byte
(%primitive header-ref fn %function-min-args-slot)))
((and (listp fn) (eq (car fn) 'lambda))
(do ((l (cadr fn) (cdr l))
(n 0 (1+ n)))
((or (null l)
(memq (car l) '(&optional &rest &key &aux &allow-other-keys)))
n)))
(t (error "~S should have been a function object." fn))))
;;; The maximum number of args of a function object.
(defun function-max-args (fn)
(cond ((compiled-function-p fn)
(ldb %function-max-args-byte
(%primitive header-ref fn %function-max-args-slot)))
((and (listp fn) (eq (car fn) 'lambda))
(do* ((l (cadr fn) (cdr l))
(n 0 (if (eq (car l) '&optional) n (1+ n))))
((or (null l) (memq (car l) '(&rest &key &aux &allow-other-keys)))
n)))
(t (error "~S should have been a function object." fn))))
;;; Does the function object have a rest arg?
(defun function-rest-arg-p (fn)
(cond ((compiled-function-p fn)
(ldb-test %function-rest-arg-byte
(%primitive header-ref fn %function-rest-arg-slot)))
((and (listp fn) (eq (car fn) 'lambda))
(dolist (a (cadr fn) nil)
(if (or (eq a '&key) (eq a '&rest)) (return t))))
(t (error "~S should have been a function object." fn))))
;;; Takes a symbol which is a function and finds its arg count by looking
;;; on its clc-args property, or actually looking at the thing in its
;;; function object slot. Save this information (on clc-args), because it's
;;; really slow to look up again if the function is interpreted, and probably
;;; not that slow to waste a cons to save the information.
(defun get-function-arg-counts (function)
(cond ((not (fboundp function)) nil)
((get function 'clc-args))
((not *examine-environment-function-information*) nil)
(t
(let ((fn-obj (symbol-function function)))
(if (and (listp fn-obj) (eq (car fn-obj) 'macro))
nil
(setf (get function 'clc-args)
(cons (function-min-args fn-obj)
(if (function-rest-arg-p fn-obj)
nil
(function-max-args fn-obj)))))))))
(defun get-declared-function-type (function)
(cond ((get function 'declared-function-type))
((not *examine-environment-function-information*) nil)
((not (fboundp function)) nil)
(t (let* ((fn-obj (symbol-function function)))
(cond ((listp fn-obj)
(case (car fn-obj)
(macro 'macro)
(lambda 'expr)
(t (error "~S is an ill-formed function object for ~S"
fn-obj function))))
((fexprp fn-obj) 'fexpr)
(t 'expr))))))