(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE (DEFPACKAGE "D-ASSEM" (§USE "LISP")))

(il:filecreated "20-Oct-86 22:51:10" il:{eris}<lispcore>sources>d-assem.\;5
 88318  

      il:|changes| il:|to:|  (il:vars il:d-assemcoms)
                             (il:structures dcode djump dlambda dtag dvar)
                             (il:props (il:d-assem il:makefile-environment))
                             (il:variables +ivar-code+ +pvar-code+ +fvar-code+ +lambda-spread+ 
                                    +nlambda-spread+ +lambda-no-spread+ +nlambda-no-spread+ 
                                    +constant-opcodes+ *bytes* *byte-count* *dtag-env* *dvar-env* 
                                    *hunk-map* *dcode* *level* *hunk-size* *pvar-count* *free-vars* 
                                    *bound-specials* *ending-depth* *stack-notes* *jump-list* 
                                    +jump-choices+ +jump-range-size-map+ +jump-sizes+)
                             (il:functions create-hunk type-name-from-size release-circularities 
                                    start-bytes emit-byte emit-byte-list end-bytes choose-op ref-var 
                                    store-var max-arg push-integer assemble-function 
                                    dlambda-from-lambda dcode-from-dlambda digest-function 
                                    digest-code store-digest-info dvar-from-lap-var lap-var-id 
                                    install-local install-var intern-var intern-tag easy-entry-p 
                                    generate-easy-entry generate-hard-entry generate-arg-check 
                                    generate-key generate-opt-and-rest stack-analyze 
                                    stack-analyze-code assemble assemble-code resolve-jumps 
                                    reduce-uncertainty splice-in-jumps compute-jump-size 
                                    convert-to-binary compute-debugging-info allocate-code-block 
                                    fixup-ptr fixup-word intern-dcode pretty-jumps)

      il:|previous| il:|date:| "10-Oct-86 01:30:07" il:{eris}<lispcore>sources>d-assem.\;4)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:d-assemcoms)

(il:rpaqq il:d-assemcoms
 ((il:* il:|;;;| "D-machine Assembler.")
                          (il:files il:d-assem-package)
                          (il:coms (il:* il:|;;| "Data structures and utilities")
                                 (il:structures dcode djump dlambda dtag dvar)
                                 (il:p (il:defprint 'dtag nil))
                                 (il:functions create-hunk type-name-from-size)
                                 (il:functions release-circularities))
                          (il:coms (il:* il:|;;| "Handy constants")
                                 (il:variables +ivar-code+ +pvar-code+ +fvar-code+)
                                 (il:variables +lambda-spread+ +nlambda-spread+ +lambda-no-spread+ 
                                        +nlambda-no-spread+)
                                 (il:variables +constant-opcodes+))
                          (il:coms (il:* il:|;;| "Opcode generation")
                                 (il:variables *bytes* *byte-count*)
                                 (il:functions start-bytes emit-byte emit-byte-list end-bytes)
                                 (il:functions choose-op ref-var store-var max-arg push-integer))
                          (il:coms (il:* il:|;;| "Main driving")
                                 (il:variables *dtag-env* *dvar-env* *hunk-map* *dcode* *level*)
                                 (il:functions assemble-function dlambda-from-lambda 
                                        dcode-from-dlambda))
                          (il:coms (il:* il:|;;| "Digesting the function")
                                 (il:variables *hunk-size* *pvar-count* *free-vars* *bound-specials*)
                                 (il:functions digest-function digest-code store-digest-info)
                                 (il:functions dvar-from-lap-var lap-var-id install-local install-var 
                                        intern-var intern-tag))
                          (il:coms (il:* il:|;;| "Function entry code")
                                 (il:functions easy-entry-p generate-easy-entry)
                                 (il:functions generate-hard-entry generate-arg-check generate-key 
                                        generate-opt-and-rest))
                          (il:coms (il:* il:|;;| "Stack analysis")
                                 (il:variables *ending-depth* *stack-notes*)
                                 (il:functions stack-analyze stack-analyze-code))
                          (il:coms (il:* il:|;;| "The guts of assembly")
                                 (il:functions assemble assemble-code))
                          (il:coms (il:* il:|;;| "Jump resolution")
                                 (il:variables *jump-list*)
                                 (il:variables +jump-choices+ +jump-range-size-map+ +jump-sizes+)
                                 (il:functions resolve-jumps reduce-uncertainty splice-in-jumps 
                                        compute-jump-size)
                                 (il:coms (il:* il:\; "Debugging jump resolution")
                                        (il:functions pretty-jumps)))
                          (il:coms (il:* il:|;;| "Conversion to binary")
                                 (il:functions convert-to-binary))
                          (il:coms (il:* il:|;;| "Setting up the debugging information")
                                 (il:functions compute-debugging-info))
                          (il:coms (il:* il:|;;| "Fixup resolution and DCODE interning")
                                 (il:functions allocate-code-block fixup-ptr fixup-word intern-dcode)
                                 )
                          (il:* il:|;;| "Arrange for the correct compiler to be used")
                          (il:prop il:filetype il:d-assem)
                          (il:* il:|;;| "Arrange for the proper makefile environment")
                          (il:prop il:makefile-environment il:d-assem)
                          (il:declare\: il:eval@compile il:dontcopy (il:files (il:loadcomp)
                                                                           il:llbasic il:llcode 
                                                                           il:llgc il:modarith))))



(il:* il:|;;;| "D-machine Assembler.")


(il:filesload il:d-assem-package)



(il:* il:|;;| "Data structures and utilities")


(defstruct dcode
 (frame-name "No name") (nlocals 0)
                                        (nfreevars 0)
                                        arg-type
                                        (num-args 0)
                                        (name-table nil)
                                        debugging-info code-array (fn-fixups nil)
                                        (sym-fixups nil)
                                        (lit-fixups nil)
                                        (type-fixups nil)
                                        (closure-p nil))

(defstruct djump
 kind tag ptr min-pc min-size forward-p size-uncertainty)

(defstruct (dlambda
 (:constructor make-dlambda
                           (required optional rest key allow-other-keys others name blip closed-over 
                                  non-local body))) required optional rest key allow-other-keys 
                                                          others name blip closed-over non-local body)

(defstruct dtag
 "LEVEL is the lexical level of this tag, for use by the stack analyzer.
STACK-DEPTH is a pair <binding-depth . depth> representing the state of the stack analyzer last time it was here.
PTR is the tail of the code list starting with this tag, used by the stack analyzer.
PC is the final location of this tag, after jump resolution.
MIN-PC is the least location at which this tag could end up, used during jump resolution.
PC-UNCERTAINTY is the amount of slack there is in the final location of this tag, used during jump resolution."
   level stack-depth ptr pc min-pc pc-uncertainty)

(defstruct dvar
 kind level slot name)

(il:defprint 'dtag nil)
(defun create-hunk (hunk-size my-slot prev-slot pop-p)
       (il:* il:|;;;| "Emit code to create a hunk of the given size and store it into PVAR my-slot.  If prev-slot is non-NIL, also emit code to link the new hunk to the one in that slot.  If pop-p is non-NIL then don't leave the hunk on the stack."
             )
       (emit-byte-list `(il:sicx (type ,(type-name-from-size hunk-size))
                               il:createcell
                               ,@(and prev-slot `(,@(choose-op '(il:pvar . il:pvarx) prev-slot)
                                                  il:rplptr.n 0))
                               ,@(store-var my-slot pop-p))))
(defun type-name-from-size (len)
       (il:pack* '\\ptrhunk (il:for hunk-size il:in il:\\hunk.ptrsizes il:when (<= len hunk-size)
                                   il:do
                                   (return hunk-size)
                                   il:finally
                                   (error "Can't make a hunk that big: ~S" len))))
(defun release-circularities (code)
       "NIL out any circularities in the LAP code given."
       (il:for inst il:in code il:do (case (car inst)
                                           ((tag)
                                            (setf (dtag-ptr (second inst))
                                                  nil)))))



(il:* il:|;;| "Handy constants")


(defconstant +ivar-code+
 0 "Code in name-table for IVARs")

(defconstant +pvar-code+
 2 "Code in name-table for PVARs")

(defconstant +fvar-code+
 3 "Code in name-table for FVARs")

(defconstant +lambda-spread+
 0 "ARGTYPE value for lambda spread functions")

(defconstant +nlambda-spread+
 1 "ARGTYPE value for nlambda spread functions")

(defconstant +lambda-no-spread+
 2 "ARGTYPE value for lambda no-spread functions")

(defconstant +nlambda-no-spread+
 3 "ARGTYPE value for nlambda no-spread functions")

(defconstant +constant-opcodes+
 '((0 . il:\'0)
                                  (1 . il:\'1)
                                  (nil . il:\'nil)
                                  (t . il:\'t)) "An AList of all constants with dedicated opcodes."
   )




(il:* il:|;;| "Opcode generation")


(defvar *bytes*
 nil "The data-structure holding the bytes of the current function.  Use (start-bytes) to create an empty one, (emit-byte) or (emit-op) to add more bytes on the end, and (end-bytes) to close it off and get an array of the bytes."
)

(defvar *byte-count*
 0 "The number of bytes put on *bytes* so far.")

(defun start-bytes nil nil)
(defun emit-byte (byte)
       (cond ((consp byte)
              (case (first byte)
                    ((:tag)
                     (setf (dtag-min-pc (second byte))
                           *byte-count*)
                     (push (second byte)
                           *jump-list*))
                    ((:jump :fjump :tjump :nfjump :ntjump)
                     (push byte *bytes*)
                     (push (make-djump :kind (first byte)
                                  :tag
                                  (second byte)
                                  :ptr *bytes* :min-pc *byte-count*)
                           *jump-list*)
                     (il:* il:\; "Increase the byte-count by the minimum size of this kind of jump.")
                     (incf *byte-count* (second (assoc (first byte)
                                                       +jump-sizes+))))
                    ((sym fn type)
                     (push byte *bytes*)
                     (push 0 *bytes*)
                     (incf *byte-count* 2))
                    ((lambda lit)
                     (push byte *bytes*)
                     (push 0 *bytes*)
                     (push 0 *bytes*)
                     (incf *byte-count* 3))
                    ((il:atom)
                     (il:* il:|;;| "ByteCompiler-style fixup, here because of a DOPVAL.  The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list."
                           )
                     (pop *bytes*)
                     (push (list 'sym (cdr byte))
                           *bytes*)
                     (push 0 *bytes*)
                     (incf *byte-count*))
                    ((il:ptr)
                     (il:* il:|;;| "ByteCompiler-style fixup, here because of a DOPVAL.  The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list."
                           )
                     (pop *bytes*)
                     (pop *bytes*)
                     (push (list 'lit (cdr byte))
                           *bytes*)
                     (push 0 *bytes*)
                     (push 0 *bytes*)
                     (incf *byte-count*))
                    (otherwise (push byte *bytes*)
                           (incf *byte-count*))))
             (t (push byte *bytes*)
                (incf *byte-count*))))
(defun emit-byte-list (l)
       (il:for byte il:in l il:do (emit-byte byte)))
(defun end-bytes nil (nreverse *bytes*))
(defun choose-op (choices arg)
       (if (<= arg (max-arg (car choices)))
           `((,(car choices) ,arg))
           `(,(cdr choices) ,(il:llsh arg 1))))
(defun ref-var (var)
       "Return a list of instructions to push the given variable's value onto the stack."
       (if (dvar-p var)
           (ecase (dvar-kind var)
                  ((:local)
                   (choose-op '(il:pvar . il:pvarx) (dvar-slot var)))
                  ((:argument)
                   (choose-op '(il:ivar . il:ivarx) (dvar-slot var)))
                  ((:free)
                   (choose-op '(il:fvar . il:fvarx) (dvar-slot var)))
                  ((:closed)
                   (let* ((level (dvar-level var))
                          (map-entry (il:find entry il:in (reverse *hunk-map*)
                                            il:suchthat
                                            (<= level (car entry))))
                          (hunk-level (car map-entry))
                          (hunk-slot (cdr map-entry)))
                         `(,@(choose-op '(il:pvar . il:pvarx) hunk-slot)
                           ,@(il:for i il:from 1 il:to (- hunk-level level)
                                    il:join
                                    (list 'il:getbaseptr.n 0)) il:getbaseptr.n
                           ,(il:llsh (dvar-slot var)
                                   1)))))
           (if (and (consp var)
                    (eq (first var)
                        ':g))
               `(il:gvar (sym ,(second var)))
               (error "BUG: This variable is neither global nor a DVAR: ~S" var))))
(defun store-var (var-or-slot pop-p)
       "Return a list of instructions to store the value on the top of stack into the given variable.  If a slot number is given instead, it is assumed to refer to a PVAR.  If POP-P is non-NIL, don't leave the value on the stack."
       (let (kind slot)
            (etypecase var-or-slot (fixnum (setq slot var-or-slot)
                                          (setq kind :local))
                   (cons (unless (eq (first var-or-slot)
                                     ':g)
                                (error "BUG: This variable is neither a global nor a DVAR: ~S" 
                                       var-or-slot))
                         (setq kind :global)
                         (setq slot (second var-or-slot)))
                   (dvar (setq slot (dvar-slot var-or-slot))
                         (setq kind (dvar-kind var-or-slot))))
            (ecase kind ((:local)
                         (if pop-p (if (<= slot (max-arg 'il:pvar_^))
                                       `((il:pvar_^ ,slot))
                                       `(,@(choose-op '(il:pvar_ . il:pvarx_) slot) il:pop))
                             (choose-op '(il:pvar_ . il:pvarx_) slot)))
                   ((:argument)
                    `(il:ivarx_ ,(il:llsh slot 1) ,@(and pop-p '(il:pop))))
                   ((:free)
                    `(il:fvarx_ ,(il:llsh slot 1) ,@(and pop-p '(il:pop))))
                   ((:closed)
                    (let* ((level (dvar-level var-or-slot))
                           (map-entry (il:find entry il:in (reverse *hunk-map*)
                                             il:suchthat
                                             (<= level (car entry))))
                           (hunk-level (car map-entry))
                           (hunk-slot (cdr map-entry)))
                          `(,@(and (not pop-p)
                                   'il:copy) ,@(choose-op '(il:pvar . il:pvarx) hunk-slot)
                                  ,@(il:for i il:from 1 il:to (- hunk-level level)
                                           il:join
                                           (list 'il:getbaseptr.n 0)) il:swap il:rplptr.n
                                  ,(il:llsh slot 1) il:pop)))
                   ((:global)
                    `(il:gvar_ (sym ,slot))))))
(defun max-arg (opcode)
       (let ((range (il:fetch il:op# il:of (il:\\findop opcode))))
            (- (second range)
               (first range))))
(defun push-integer (n)
       (cond ((zerop n)
              '(il:\'0))
             ((= n 1)
              '(il:\'1))
             ((<= -256 n -1)
              `(il:snic ,(+ n 256)))
             ((<= 0 n 255)
              `(il:sic ,n))
             ((<= 255 n 65535)
              `(il:sicx ,(il:lrsh n 8) ,(logand n 255)))
             (t `(il:gconst (lit ,n)))))



(il:* il:|;;| "Main driving")


(defvar *dtag-env*
 nil 
       "A hash-table mapping the EQL-unique ID of a LAP tag into the DTAG structure used by D-ASSEM.")

(defvar *dvar-env*
 nil 
  "A hash-table mapping the EQL-unique ID of a LAP variable into the DVAR structure used by D-ASSEM.")

(defvar *hunk-map*
 nil "An AList mapping lexical level numbers into the PVAR number of a slot in the current frame holding the hunk for that level."
)

(defvar *dcode*
 0 "The currently-under-construction DCODE structure.")

(defvar *level*
 0 "The current lexical nesting level.")

(defun assemble-function (lap-fn)
       "LAP-FN is a LAP-format function description (a LAMBDA).  Return the DCODE structure that results from assembling it into D-machine bytecodes."
       (let ((*dvar-env* (make-hash-table :test 'eql))
             (*dtag-env* (make-hash-table :test 'eql)))
            (dcode-from-dlambda (dlambda-from-lambda (copy-tree lap-fn))
                   0)))
(defun dlambda-from-lambda (lap-fn)
       "Break out the fields of a LAP lambda and return them in the form of a DLAMBDA structure."
       (il:destructuring-bind ((required &key optional rest key allow-other-keys others name blip 
                                      closed-over non-local)
                               &rest body)
              (cdr lap-fn)
              (make-dlambda required optional rest key allow-other-keys others name blip closed-over
                     (mapcar #'lap-var-id non-local)
                     body)))
(defun dcode-from-dlambda (dlambda level)
       "LEVEL is the length of the chain of hunks that will be passed to the result of assembling DLAMBDA at runtime."
       (let ((*dcode* (make-dcode :frame-name (dlambda-name dlambda)))
             (*hunk-map* (and (> level 0)
                              `((,level . 0))))
             (*hunk-size* (if (> level 0)
                              1 0))
             (*bytes* (start-bytes))
             (*byte-count* 0)
             (*jump-list* nil)
             (*pvar-count* (if (> level 0)
                               1 0))
             (*level* level)
             (easy-entry (easy-entry-p dlambda)))
            (il:* il:|;;| "Pass 0: Intern all of the variables and tags")
            (digest-function dlambda easy-entry)
            (il:* il:|;;| "Pass 1: Translate LAP code into opcodes and bytes.")
            (if easy-entry (generate-easy-entry dlambda)
                (generate-hard-entry dlambda))
            (stack-analyze (dlambda-body dlambda))
            (assemble (dlambda-body dlambda))
            (release-circularities (dlambda-body dlambda))
            (emit-byte 'il:-x-)
            (setq *bytes* (end-bytes))
            (il:* il:|;;| "Pass 1-1/2: Resolve the uncertainty in jump sizes and distances.")
            (unless (null *jump-list*)
                   (resolve-jumps (reverse *jump-list*)))
            (il:* il:|;;| "Pass 2: Convert the byte-list into its final binary form and create the fixup lists.  This pass also performs the recursion necessary to compile nested lambdas."
                  )
            (convert-to-binary *bytes*)
            (il:* il:|;;| "Fill in the last few bits of the DCODE and quit.")
            (compute-debugging-info dlambda)
            (setf (dcode-closure-p *dcode*)
                  (if (null (dlambda-non-local dlambda))
                      :function :closure))
            *dcode*))



(il:* il:|;;| "Digesting the function")


(defvar *hunk-size*
 0 "The number of hunk slots allocated so far.")

(defvar *pvar-count*
 0 "The number of PVAR allocated so far.")

(defvar *free-vars*
 nil "An AList mapping DVARs for the free variables in a function into the number of times they're referenced in the function."
)

(defvar *bound-specials*
 nil "A list of the special variables bound in this frame.")

(defun digest-function (dlambda easy-entry)
       (let* ((closed-over (dlambda-closed-over dlambda))
              (ivar-count 0)
              (*free-vars* nil)
              (*bound-specials* nil))
             (il:* il:|;;| 
               "Allocate slots for the top-level hunk and the blip slot variable, if they're needed."
                   )
             (when (not (null (dlambda-blip dlambda)))
                   (il:* il:\; "This can lead to a wasted PVAR0, but I'm not losing sleep over it.")
                   (install-var (dlambda-blip dlambda)
                          nil :local 1)
                   (setq *pvar-count* 2))
             (when (not (null closed-over))
                   (incf *level*)
                   (il:* il:\; "The lexical level just changed.")
                   (push (cons *level* *pvar-count*)
                         *hunk-map*)
                   (incf *pvar-count*))
             (il:* il:|;;| "Intern the required parameters.")
             (il:for tail il:on (dlambda-required dlambda)
                    il:do
                    (setf (car tail)
                          (install-var (car tail)
                                 closed-over :argument ivar-count))
                    (incf ivar-count))
             (il:* il:|;;| "And then the optional parameters and their supplied-p colleagues.")
             (il:for opt-var il:in (dlambda-optional dlambda)
                    il:do
                    (cond (easy-entry (setf (first opt-var)
                                            (install-var (first opt-var)
                                                   closed-over :argument ivar-count))
                                 (incf ivar-count))
                          (t (setf (first opt-var)
                                   (install-local (first opt-var)
                                          closed-over))
                             (digest-code (second opt-var))
                             (setf (third opt-var)
                                   (install-local (third opt-var)
                                          closed-over)))))
             (when easy-entry (setf (dcode-num-args *dcode*)
                                    ivar-count))
             (il:* il:|;;| "Next comes the rest and keyword parameters.")
             (when (not easy-entry)
                   (when (and (not (null (dlambda-rest dlambda)))
                              (not (eq :ignored (dlambda-rest dlambda))))
                         (setf (dlambda-rest dlambda)
                               (install-local (dlambda-rest dlambda)
                                      closed-over)))
                   (il:for key-var il:in (dlambda-key dlambda)
                          il:do
                          (setf (second key-var)
                                (install-local (second key-var)
                                       closed-over))
                          (digest-code (third key-var))
                          (setf (fourth key-var)
                                (install-local (fourth key-var)
                                       closed-over))))
             (il:* il:|;;| "Then intern any stragglers on the closed-over list.")
             (il:for var il:in closed-over il:do
                    (when (and (consp var)
                               (null (gethash (third var)
                                            *dvar-env*)))
                          (setf (gethash (third var)
                                       *dvar-env*)
                                (make-dvar :kind :closed :slot *hunk-size* :level *level* :name
                                       (second var)))
                          (incf *hunk-size*)))
             (il:* il:|;;| "And, at long last, digest the body of the function.")
             (digest-code (dlambda-body dlambda))
             (il:* il:|;;| "Record the results of this digestion (yecch...).")
             (store-digest-info)))
(defun digest-code (lap-code)
       (il:for tail il:on lap-code il:do
              (let ((inst (car tail)))
                   (case (first inst)
                         ((:var :var_)
                          (setf (second inst)
                                (intern-var (second inst))))
                         ((:lambda)
                          (setf (cdr inst)
                                (cons (dlambda-from-lambda inst)
                                      nil)))
                         ((:bind)
                          (il:* (if (and (consp var)
                                         (null (gethash (third var)
                                                      *dvar-env*)))
                                    (install-local var nil)
                                    (error "Variable in :BIND appeared earlier: ~S" var)))
                          (flet ((install-new (var)
                                        (if (and (consp var)
                                                 (null (gethash (third var)
                                                              *dvar-env*)))
                                            (install-local var nil)
                                            (gethash (third var)
                                                   *dvar-env*))))
                                (setf (second inst)
                                      (mapcar #'install-new (second inst)))
                                (setf (third inst)
                                      (mapcar #'install-new (third inst)))))
                         ((:unbind :dunbind)
                          (setf (second inst)
                                (length (second inst))
                                (third inst)
                                (length (third inst))))
                         ((:tag)
                          (setf (second inst)
                                (intern-tag (second inst)))
                          (setf (dtag-ptr (second inst))
                                tail)
                          (setf (dtag-level (second inst))
                                *level*))
                         ((:jump :fjump :tjump :nfjump :ntjump)
                          (setf (second inst)
                                (intern-tag (second inst))))
                         ((:close)
                          (let ((*level* (1+ *level*))
                                (*hunk-size* (if (> *level* 0)
                                                 1 0)))
                               (il:* il:|;;| "In setting up the new lexical environment, don't forget to leave a slot for linking the hunks together, if necessary."
                                     )
                               (let ((dvars (il:for var il:in (second inst)
                                                   il:collect
                                                   (setf (gethash (third var)
                                                                *dvar-env*)
                                                         (make-dvar :kind :closed :slot *hunk-size* 
                                                                :level *level* :name (second var)))
                                                   (incf *hunk-size*))))
                                    (setf (rest inst)
                                          (list* dvars *pvar-count* (cddr inst))))
                               (incf *pvar-count*)
                               (il:* il:\; "Allocate a slot for the new hunk.")
                               (digest-code (cddr inst))))))))
(defun store-digest-info nil (let ((free-var-alist (sort *free-vars* #'< :key #'cdr)))
                                  (il:* il:|;;| "This first bit gets the entries on the name-table in the right order by building the table backwards.  The final order is PVARs, IVARs, FVARs with the PVARs and IVARs in reverse order.  This lets the free variable lookup find the correct variable first."
                                        )
                                  (il:for pair il:in free-var-alist il:as slot il:from
                                         (1- (+ (length free-var-alist)
                                                *pvar-count*))
                                         il:by -1 il:do (push (list +fvar-code+ slot
                                                                    (dvar-name (car pair)))
                                                              (dcode-name-table *dcode*))
                                         (setf (dvar-slot (car pair))
                                               slot)
                                         (il:* il:\; 
                                           "While we're at this, assign slots to the free variables."
                                               ))
                                  (il:for dvar il:in (nreverse *bound-specials*)
                                         il:do
                                         (push (list (ecase (dvar-kind dvar)
                                                            ((:local)
                                                             +pvar-code+)
                                                            ((:argument)
                                                             +ivar-code+))
                                                     (dvar-slot dvar)
                                                     (dvar-name dvar))
                                               (dcode-name-table *dcode*)))
                                  (il:* il:|;;| 
                                       "Now to fill in some of the more mundane fields of the DCODE."
                                        )
                                  (setf (dcode-nlocals *dcode*)
                                        *pvar-count*)
                                  (setf (dcode-nfreevars *dcode*)
                                        (length free-var-alist))))
(defun dvar-from-lap-var (lap-var)
       (or (gethash (lap-var-id lap-var)
                  *dvar-env*)
           (error "The LAP var ~S should have been interned by now." lap-var)))
(defun lap-var-id (var)
       (if (consp var)
           (third var)
           var))
(defun install-local (var closed-over)
       (and var (let ((dvar (install-var var closed-over :local *pvar-count*)))
                     (when (eq :local (dvar-kind dvar))
                           (incf *pvar-count*))
                     dvar)))
(defun install-var (var closed-over kind slot)
       (and var (il:destructuring-bind
                 (scope name id)
                 var
                 (cond ((member id closed-over :key #'lap-var-id)
                        (prog1 (setf (gethash id *dvar-env*)
                                     (make-dvar :kind :closed :slot *hunk-size* :level *level* :name 
                                            name))
                               (incf *hunk-size*)))
                       (t (let ((dvar (setf (gethash id *dvar-env*)
                                            (make-dvar :kind (if (eq scope ':f)
                                                                 :free kind)
                                                   :slot slot :name name))))
                               (case scope ((:s)
                                            (push dvar *bound-specials*))
                                     ((:f)
                                      (push (cons dvar 1)
                                            *free-vars*)))
                               dvar))))))
(defun intern-var (var)
       (if (consp var)
           (if (eq (first var)
                   ':g)
               (il:* il:\; "Global vars don't get interned.")
               var
               (let ((dvar (gethash (third var)
                                  *dvar-env*)))
                    (cond ((not (null dvar))
                           (when (eq :free (dvar-kind dvar))
                                 (incf (cdr (assoc dvar *free-vars*))))
                           dvar)
                          (t (install-local var nil)))))
           (or (gethash var *dvar-env*)
               (error "Unknown LAP variable ID: ~S" var))))
(defun intern-tag (id)
       (or (gethash id *dtag-env*)
           (setf (gethash id *dtag-env*)
                 (make-dtag))))



(il:* il:|;;| "Function entry code")


(defun easy-entry-p (dlambda)
       (and (or (null (dlambda-rest dlambda))
                (eq :ignored (dlambda-rest dlambda)))
            (null (dlambda-key dlambda))
            (il:for opt-var il:in (dlambda-optional dlambda)
                   il:always
                   (and (equal '((:const nil)) (second opt-var))
                        (null (third opt-var))))))
(defun generate-easy-entry (dlambda)
       (il:* il:|;;| "Emit code to create the hunk for this level and leave it on top of stack.  We'll use it in the processing of the arguments."
             )
       (when (not (null (dlambda-closed-over dlambda)))
             (create-hunk *hunk-size* (cdar *hunk-map*)
                    (and (> *level* 1)
                         0)
                    nil))
       (il:* il:|;;| "The required and optional parameters are treated alike in the easy entry.  If any of them are closed over, copy them into the hunk."
             )
       (il:for dvar il:in (append (dlambda-required dlambda)
                                 (mapcar #'first (dlambda-optional dlambda)))
              il:as ivar-count il:from 0 il:do
              (when (eq :closed (dvar-kind dvar))
                    (emit-byte-list `(,@(choose-op '(il:ivar . il:ivarx) ivar-count)
                                      il:rplptr.n
                                      ,(il:llsh (dvar-slot dvar)
                                              1)))))
       (setf (dcode-arg-type *dcode*)
             +lambda-spread+))
(defun generate-hard-entry (dlambda)
       (let ((num-required (length (dlambda-required dlambda)))
             (num-optional (length (dlambda-optional dlambda))))
            (il:* il:|;;| "Emit code to create the hunk for this level and store it away.")
            (when (not (null (dlambda-closed-over dlambda)))
                  (create-hunk *hunk-size* (cdar *hunk-map*)
                         (and (> *level* 1)
                              0)
                         t))
            (il:* il:|;;| 
                "Generate a check for a bad number of arguments, unless there are no illegal values."
                  )
            (unless (and (zerop num-required)
                         (or (and (dlambda-rest dlambda)
                                  (not (eq :ignored (dlambda-rest dlambda))))
                             (dlambda-key dlambda)))
                   (generate-arg-check dlambda))
            (il:* il:|;;| "Copy the closed required args to the hunk.")
            (il:for dvar il:in (dlambda-required dlambda)
                   il:as ivar-count il:from 0 il:do
                   (when (eq :closed (dvar-kind dvar))
                         (emit-byte-list `(,@(choose-op '(il:pvar . il:pvarx) (cdar *hunk-map*))
                                           ,@(choose-op '(il:ivar . il:ivarx) ivar-count) il:rplptr.n
                                           ,(il:llsh *hunk-size* 1) il:pop))))
            (il:* il:|;;| "Generate code for the optional and rest arguments.")
            (generate-opt-and-rest dlambda num-required num-optional)
            (il:* il:|;;| "Generate code for the keyword arguments.")
            (generate-key dlambda num-required num-optional)
            (il:* il:|;;| "Fill in some information in the DCODE structure.")
            (setf (dcode-arg-type *dcode*)
                  +lambda-no-spread+)
            (setf (dcode-num-args *dcode*)
                  -1)))
(defun generate-arg-check (dlambda)
       (il:* il:|;;;| 
             "Generate code that signals an error if too few or too many arguments are given.")
       (let* ((min-args (length (dlambda-required dlambda)))
              (max-args (and (null (dlambda-rest dlambda))
                             (null (dlambda-key dlambda))
                             (+ min-args (length (dlambda-optional dlambda)))))
              (ok-tag (make-dtag))
              (bad-tag (make-dtag)))
             (if (null max-args)
                 (emit-byte-list `(il:myargcount ,@(push-integer (1- min-args)) il:greaterp
                                         (il:tjump ,ok-tag)
                                         ,@(push-integer min-args) il:\'nil il:fn2 (fn 
                                                                                   si::argument-error
                                                                                       )
                                         il:pop
                                         (tag ,ok-tag)))
                 (emit-byte-list `(il:myargcount ,@(push-integer (1- min-args)) il:greaterp
                                         (il:fjump ,bad-tag)
                                         il:myargcount
                                         ,@(push-integer max-args) il:greaterp (il:fjump ,ok-tag)
                                         (tag ,bad-tag)
                                         ,@(push-integer min-args)
                                         ,@(push-integer max-args) il:fn2 (fn si::argument-error)
                                         il:pop
                                         (tag ,ok-tag))))))
(defun
 generate-key
 (dlambda num-required num-optional)
 "Generate code to check for and default the keyword arguments."
 (let ((start (+ 1 num-required num-optional)))
      (il:for tail il:on (dlambda-key dlambda)
             il:do
             (il:destructuring-bind
              (keyword var code svar)
              (car tail)
              (let ((found-tag (make-dtag))
                    (next-tag (make-dtag)))
                   (emit-byte-list `(il:aconst (sym ,keyword)
                                           il:findkey
                                           ,start
                                           (il:ntjump ,found-tag)))
                   (il:* il:|;;| "Not there; compute the init-form.")
                   (stack-analyze code 1)
                   (assemble code)
                   (emit-byte-list `(,@(store-var var t)
                                     ,@(and svar `(il:\'nil ,@(store-var svar t)))
                                     (il:jump ,next-tag)
                                     (tag ,found-tag)
                                     il:arg0
                                     ,@(store-var var t)
                                     ,@(and svar `(il:\'t ,@(store-var svar t)))
                                     (tag ,next-tag))))))))
(defun
 generate-opt-and-rest
 (dlambda num-required num-optional)
 (let
  ((opt-init-values nil)
   (after-opts-tag (make-dtag)))
  (il:* il:|;;| "OPT-INIT-VALUES will hold a list of lists (var svar tag . lap-code), one for each opt-var.  These will be generated in order after we take care of the rest argument."
        )
  (unless (zerop num-optional)
         (il:* il:|;;| "Convert the arg-count into a count of remaining arguments.")
         (emit-byte-list `(il:myargcount ,@(and (not (zerop num-required))
                                                `(,@(push-integer num-required) il:idifference))))
         (il:* il:|;;| "Generate the code for testing for each optional variable.  If it's there, copy it to its slot and set the svar, if one exists.  Otherwise, jump into the middle of the stream of init-form computations."
               )
         (il:for tail il:on (dlambda-optional dlambda)
                il:as ivar-count il:from (1+ num-required)
                il:do
                (let ((tag (make-dtag)))
                     (il:destructuring-bind
                      (var code svar)
                      (car tail)
                      (emit-byte-list `(,@(and (cdr tail)
                                               '(il:copy))
                                        il:\'0 eq (il:tjump ,tag)
                                        ,@(push-integer ivar-count) il:arg0 ,@(store-var var t)
                                        ,@(and svar `(il:\'t ,@(store-var svar t)))
                                        ,@(and (cdr tail)
                                               '(il:\'1 il:idifference))))
                      (push (list* var svar tag code)
                            opt-init-values)))))
  (il:* il:|;;| "All of the &optionals were provided.  Handle the &rest argument.")
  (when (and (dlambda-rest dlambda)
             (not (eq :ignored (dlambda-rest dlambda))))
        (emit-byte-list `(il:\'nil il:myargcount il:restlist ,(+ 1 num-required num-optional)
                                ,@(store-var (dlambda-rest dlambda)
                                         t))))
  (il:* il:|;;| "Compute the default values for the various optional parameters one after another.  The testing code above jumps into the middle of this."
        )
  (unless (zerop num-optional)
         (emit-byte `(il:jump ,after-opts-tag))
         (il:* il:\; "If we fall into this code, all of the optionals were provided, so jump around the default-value calculations."
               )
         (il:for vars-tag-code il:in (nreverse opt-init-values)
                il:do
                (emit-byte `(tag ,(caddr vars-tag-code)))
                (stack-analyze (cdddr vars-tag-code)
                       1)
                (assemble (cdddr vars-tag-code))
                (emit-byte-list (store-var (car vars-tag-code)
                                       t))
                (when (cadr vars-tag-code)
                      (il:* il:\; "There's an svar")
                      (emit-byte-list `(il:\'nil ,@(store-var (cadr vars-tag-code)
                                                          t)))))
         (when (and (dlambda-rest dlambda)
                    (not (eq :ignored (dlambda-rest dlambda))))
               (il:* il:\; 
                   "If not all of the optionals were there, then there can't be any &rest arguments."
                     )
               (emit-byte-list `(il:\'nil ,@(store-var (dlambda-rest dlambda)
                                                   t))))
         (emit-byte `(tag ,after-opts-tag)))))



(il:* il:|;;| "Stack analysis")


(defvar *ending-depth*
 nil 
                         "An AList mapping lexical level to the stack depth at exit from that level.")

(defvar *stack-notes*
 nil "An AList mapping the IDs of NOTE-STACK directives into the absolute stack depth at that point in the code."
)

(defun stack-analyze (code &optional (expected-ending-depth 0))
       "Walk the given code annotating the tags in it with information about the stack and binding depth of control at that point."
       (let ((*level* *level*)
             (*stack-notes* nil)
             (*ending-depth* (list (cons *level* nil))))
            (stack-analyze-code code 0 nil)
            (let ((ending-depth (cdr (first *ending-depth*))))
                 (assert (or (null ending-depth)
                             (= ending-depth expected-ending-depth))
                        nil "Code doesn't leave stack empty!"))))
(defun stack-analyze-code (code init-depth init-binding-depth)
       "Annotate the tags in CODE with the stack and binding depth at those points in execution, assuming that the stack depth is INIT-DEPTH and the binding depth is as in INIT-BINDING-DEPTH on entry to the code."
       (let ((depth init-depth)
             (binding-depth init-binding-depth))
            (il:for inst il:in code il:do
                   (ecase (car inst)
                          ((:tag)
                           (cond ((null (dtag-stack-depth (second inst)))
                                  (setf (dtag-stack-depth (second inst))
                                        (cons binding-depth depth))
                                  (assert (= *level* (dtag-level (second inst)))
                                         nil "Inconsistent level at tag ~S" (second inst)))
                                 (t (assert (equal (cons binding-depth depth)
                                                   (dtag-stack-depth (second inst)))
                                           nil "Inconsistent stack depths at tag ~S" (second inst))
                                    (return-from stack-analyze-code))))
                          ((:jump)
                           (stack-analyze-code (dtag-ptr (second inst))
                                  depth binding-depth)
                           (return-from stack-analyze-code))
                          ((:fjump :tjump)
                           (decf depth)
                           (stack-analyze-code (dtag-ptr (second inst))
                                  depth binding-depth))
                          ((:nfjump :ntjump)
                           (stack-analyze-code (dtag-ptr (second inst))
                                  depth binding-depth)
                           (decf depth))
                          ((:var :copy :const :lambda :push-tag)
                           (incf depth))
                          ((:var_ :swap)
                           (il:* il:\; "Net stack effect is zero."))
                          ((:pop)
                           (decf depth))
                          ((:note-stack)
                           (push (cons (second inst)
                                       depth)
                                 *stack-notes*))
                          ((:set-stack :dset-stack)
                           (let ((lookup (assoc (second inst)
                                                *stack-notes*)))
                                (when (null lookup)
                                      (error ":NOTE-STACK not seen before :SET-STACK"))
                                (setq depth (setf (second inst)
                                                  (cdr lookup)))
                                (il:while (and binding-depth (>= (cdr (first binding-depth))
                                                                 depth))
                                       il:do
                                       (pop binding-depth))
                                (if (eq ':set-stack (first inst))
                                    (incf depth))))
                          ((:bind)
                           (il:* il:|;;| "This takes into account the popping of some number of values into the variables and then the pushing of the binding mark(s)."
                                 )
                           (decf depth (length (second inst)))
                           (push (cons (fourth inst)
                                       depth)
                                 binding-depth)
                           (incf depth (max 1 (floor (+ (length (third inst))
                                                        14)
                                                     15))))
                          ((:unbind :dunbind)
                           (unless (eql (fourth inst)
                                        (car (first binding-depth)))
                                  (error "Mismatched :BIND and :UNBIND."))
                           (setq depth (cdr (pop binding-depth)))
                           (when (eq ':unbind (first inst))
                                 (incf depth)))
                          ((:fn)
                           (decf depth (1- (third inst))))
                          ((:return)
                           (return-from stack-analyze-code))
                          ((:close)
                           (let* ((*level* (1+ *level*))
                                  (*ending-depth* (cons (cons *level* nil)
                                                        *ending-depth*)))
                                 (stack-analyze-code (cdddr inst)
                                        depth binding-depth)
                                 (setq depth (cdr (first *ending-depth*)))
                                 (when (null depth)
                                       (return-from stack-analyze-code))))))
            (let ((lookup (assoc *level* *ending-depth*)))
                 (assert (not (cdr lookup))
                        nil "Ran off end twice")
                 (when (null (cdr lookup))
                       (setf (cdr lookup)
                             depth)))))



(il:* il:|;;| "The guts of assembly")


(defun assemble (lap-code)
       (il:* il:|;;;| "Translate LAP code into D-machine bytecodes.")
       (assemble-code lap-code 0 nil))
(defun
 assemble-code
 (lap-code depth binding-depth)
 (il:* il:|;;;| "Translate LAP code into D-machine bytecodes.")
 (do
  ((tail lap-code (cdr tail))
   inst)
  ((endp tail))
  (setq inst (first tail))
  (macrolet
   ((incr (var &optional (delta 1))
          `(and ,var (setq ,var (+ ,var ,delta))))
    (decr (var &optional (delta 1))
          `(and ,var (setq ,var (- ,var ,delta)))))
   (ecase
    (car inst)
    ((:var)
     (emit-byte-list (ref-var (second inst)))
     (incr depth))
    ((:var_)
     (emit-byte-list (store-var (second inst)
                            (cond ((eq ':pop (first (second tail)))
                                   (setq tail (cdr tail))
                                   (decr depth)
                                   t)
                                  (t nil)))))
    ((:copy)
     (emit-byte 'il:copy)
     (incr depth))
    ((:swap)
     (emit-byte 'il:swap))
    ((:const)
     (let* ((value (second inst))
            (lookup (assoc value +constant-opcodes+)))
           (cond ((not (null lookup))
                  (emit-byte (cdr lookup)))
                 ((symbolp value)
                  (emit-byte-list `(il:aconst (sym ,value))))
                 ((integerp value)
                  (emit-byte-list (push-integer value)))
                 (t (emit-byte-list `(il:gconst (lit ,value))))))
     (incr depth))
    ((:lambda)
     (let* ((dlambda (second inst))
            (non-locals (dlambda-non-local dlambda)))
           (cond ((null non-locals)
                  (emit-byte-list `(il:gconst (lambda 1 ,dlambda))))
                 (t (il:* il:|;;| "This will need to be a closure.  Find our best hunk for it and construct a closure object around it and the lambda."
                          )
                    (let* ((lambda-level (il:find var il:in non-locals il:largest (dvar-level
                                                                                   (dvar-from-lap-var
                                                                                    var))
                                                il:finally
                                                (return il:$$extreme)))
                           (map-entry (il:find entry il:in (reverse *hunk-map*)
                                             il:suchthat
                                             (>= (car entry)
                                                 lambda-level)))
                           (hunk-level (car map-entry))
                           (hunk-slot (cdr map-entry)))
                          (emit-byte-list `(il:sicx (type il:compiled-closure)
                                                  il:createcell il:gconst (lambda ,hunk-level
                                                                                 ,dlambda)
                                                  il:rplptr.n 0 ,@(choose-op '(il:pvar . il:pvarx) 
                                                                         hunk-slot) il:rplptr.n 2))))
                 )
           (incr depth)))
    ((:pop)
     (emit-byte 'il:pop)
     (decr depth))
    ((:note-stack)
     (il:* il:\; "Now a no-op; used during stack analysis."))
    ((:set-stack :dset-stack)
     (let ((desired-depth (second inst)))
          (cond ((null depth)
                 (il:* il:\; 
                       "We don't know where the stack is now, so use the spanking new UNWIND opcode."
                       )
                 (emit-byte-list `(il:unwind (unwind ,(second inst))
                                         ,(if (eq ':set-stack (first inst))
                                              1 0)))
                 (il:while (and binding-depth (>= (car binding-depth)
                                                  desired-depth))
                        il:do
                        (pop binding-depth)))
                (t (let ((unbind-op (if (eq ':set-stack (first inst))
                                        'il:unbind
                                        'il:dunbind)))
                        (il:while (and binding-depth (>= (car binding-depth)
                                                         desired-depth))
                               il:do
                               (emit-byte unbind-op)
                               (setq depth (pop binding-depth)))
                        (let ((pops (- depth desired-depth)))
                             (case pops ((0)
                                         (il:* il:\; "Already there. Done."))
                                   ((1)
                                    (if (eq unbind-op 'il:unbind)
                                        (emit-byte-list '(il:swap il:pop))
                                        (emit-byte 'il:pop)))
                                   (otherwise (if (eq unbind-op 'il:unbind)
                                                  (emit-byte-list `(il:store.n ,(1- pops) il:pop.n
                                                                          ,(1- pops)))
                                                  (emit-byte-list `(il:pop.n ,pops))))))
                        (if (eq unbind-op 'il:unbind)
                            (incr depth)))))))
    ((:bind)
     (labels ((do-bind (num-values num-nils starting-slot)
                     (cond ((> num-values 15)
                            (error "Too many values bound in a :BIND: ~S" num-values))
                           ((> num-nils 15)
                            (do-bind num-values 15 starting-slot)
                            (do-bind 0 (- num-nils 15)
                                   (+ starting-slot num-values 15)))
                           (t (emit-byte-list `(il:bind ,(+ (il:llsh num-nils 4)
                                                            num-values)
                                                      ,(1- (+ starting-slot num-values num-nils))))
                              (incr depth)))))
            (let* ((values (second inst))
                   (num-values (length values))
                   (nils (third inst))
                   (num-nils (length nils)))
                  (decr depth (+ num-values num-nils))
                  (push depth binding-depth)
                  (do-bind num-values num-nils (cond (values (dvar-slot (car values)))
                                                     (nils (dvar-slot (car nils)))
                                                     (t 1))))))
    ((:unbind :dunbind)
     (dotimes (i (floor (+ (second inst)
                           (third inst)
                           14)
                        15))
            (emit-byte (first inst)))
     (setq depth (pop binding-depth))
     (if (eq (first inst)
             ':unbind)
         (incr depth)))
    ((:tag)
     (emit-byte `(:tag ,(second inst)))
     (let ((stack-depth (dtag-stack-depth (second inst))))
          (setq depth (cdr stack-depth))
          (setq binding-depth (mapcar #'cdr (car stack-depth)))))
    ((:push-tag)
     (emit-byte-list (push-integer (dtag-pc (second inst))))
     (incr depth))
    ((:jump :tjump :fjump :ntjump :nfjump)
     (emit-byte inst)
     (decr depth))
    ((:fn)
     (let ((name (second inst))
           (num-args (third inst)))
          (cond ((symbolp name)
                 (let ((dopval (get name 'il:dopval)))
                      (cond ((not (null dopval))
                             (assert (consp dopval)
                                    nil "DOPVAL for ~S is not a list: ~S" name dopval)
                             (il:for item il:inside (if (atom (car dopval))
                                                        (list dopval)
                                                        dopval)
                                    il:do
                                    (cond ((atom item)
                                           (funcall item)
                                           (return))
                                          ((or (null (car item))
                                               (= (car item)
                                                  num-args))
                                           (mapcar #'emit-byte (cdr item))
                                           (return)))
                                    il:finally
                                    (error "Illegal number of arguments to ~S: ~S" name num-args)))
                            (t (emit-byte-list (case num-args ((0)
                                                               '(il:fn0))
                                                     ((1)
                                                      '(il:fn1))
                                                     ((2)
                                                      '(il:fn2))
                                                     ((3)
                                                      '(il:fn3))
                                                     ((4)
                                                      '(il:fn4))
                                                     (otherwise `(il:fnx ,num-args))))
                               (emit-byte `(fn ,name))))))
                ((and (consp name)
                      (eq :opcodes (car name)))
                 (emit-byte-list (cdr name)))
                (t (error "BUG: Weird argument to :FN: ~S" name)))
          (decr depth (1- num-args))))
    ((:return)
     (emit-byte 'return))
    ((:close)
     (il:* il:\; "After digestion, this looks like this:")
     (il:* il:\; "(:CLOSE dvars hunk-slot . code).")
     (create-hunk (length (second inst))
            (third inst)
            (cdar *hunk-map*)
            t)
     (let* ((*level* (1+ *level*))
            (*hunk-map* (cons (cons *level* (third inst))
                              *hunk-map*)))
           (assemble-code (cdddr inst)
                  depth binding-depth)))))))



(il:* il:|;;| "Jump resolution")


(defvar *jump-list*
 nil "A list of DJUMP and DTAG structures for use by jump resolution.")

(defconstant +jump-choices+
 '((:jump il:jump il:jumpx il:jumpxx)
                              (:fjump il:fjump il:fjumpx (il:tjump 2))
                              (:tjump il:tjump il:tjumpx (il:fjump 2))
                              (:nfjump il:nfjump il:nfjumpx)
                              (:ntjump il:ntjump il:ntjumpx)) 

                                                  (il:* il:|;;;| "AList from kinds of jumps to lists of choices for implementation of that kind of jump.  See SPLICE-IN-JUMPS for details.")

   )

(defconstant +jump-range-size-map+
 '((:jump (-128 . 3)
                                            (2 . 2)
                                            (18 . 1)
                                            (128 . 2)
                                            (32768 . 3))
                                     (:fjump (-128 . 4)
                                            (2 . 2)
                                            (18 . 1)
                                            (128 . 2)
                                            (32768 . 4))
                                     (:tjump (-128 . 4)
                                            (2 . 2)
                                            (18 . 1)
                                            (128 . 2)
                                            (32768 . 4))
                                     (:nfjump (-128 . 6)
                                            (128 . 2)
                                            (32768 . 6))
                                     (:ntjump (-128 . 6)
                                            (128 . 2)
                                            (32768 . 6))) 

                                                  (il:* il:|;;;| "An AList mapping kinds of jumps into an range-to-size table.  The table is a list of pairs, sorted on the CAR.  The shortest jump for a given distance is the CDR of the first pair whose CAR is strictly greater than the distance.")

   )

(defconstant +jump-sizes+
 '((:jump 1 3)
                            (:fjump 1 4)
                            (:tjump 1 4)
                            (:nfjump 2 6)
                            (:ntjump 2 6)) 
                      "AList mapping kinds of jumps into the range of sizes for that kind, in bytes."
   )

(defun resolve-jumps (jump-list)
       (il:bind (cumulative-uncertainty il:_ 0)
              il:for jump-or-tag il:in jump-list il:do
              (etypecase jump-or-tag (dtag (setf (dtag-pc-uncertainty jump-or-tag)
                                                 cumulative-uncertainty))
                     (djump (let ((range (assoc (djump-kind jump-or-tag)
                                                +jump-sizes+)))
                                 (setf (djump-forward-p jump-or-tag)
                                       (> (dtag-min-pc (djump-tag jump-or-tag))
                                          (djump-min-pc jump-or-tag)))
                                 (setf (djump-min-size jump-or-tag)
                                       (second range))
                                 (incf cumulative-uncertainty (setf (djump-size-uncertainty 
                                                                           jump-or-tag)
                                                                    (- (third range)
                                                                       (second range))))))))
       (il:while (reduce-uncertainty jump-list))
       (splice-in-jumps jump-list))
(defun reduce-uncertainty (jump-list)
       (let ((decrease-in-uncertainty 0)
             (increase-in-min-pc 0)
             (cumulative-uncertainty 0))
            (il:for jump-or-tag il:in jump-list il:do
                   (etypecase jump-or-tag (dtag (il:* il:\; 
                                                   "Just record the current uncertainty at this tag."
                                                      )
                                                (setf (dtag-pc-uncertainty jump-or-tag)
                                                      cumulative-uncertainty)
                                                (incf (dtag-min-pc jump-or-tag)
                                                      increase-in-min-pc))
                          (djump (incf (djump-min-pc jump-or-tag)
                                       increase-in-min-pc)
                                 (when (> (djump-size-uncertainty jump-or-tag)
                                          0)
                                       (il:* il:\; "This is a jump we can hope to improve.")
                                       (let ((tag (djump-tag jump-or-tag))
                                             (kind (djump-kind jump-or-tag))
                                             (jump jump-or-tag)
                                             min-distance max-distance min-size max-size)
                                            (cond ((djump-forward-p jump)
                                                   (il:* il:|;;| "In computing the min and max distance between a forward jump and its tag, we must adjust for the changes we've made so far this pass."
                                                         )
                                                   (setq min-distance (+ (- (dtag-min-pc tag)
                                                                            (djump-min-pc jump))
                                                                         increase-in-min-pc))
                                                   (setq max-distance (+ (- (dtag-pc-uncertainty
                                                                             tag)
                                                                            (+ 
                                                                              decrease-in-uncertainty 
                                                                               cumulative-uncertainty
                                                                               ))
                                                                         min-distance)))
                                                  (t (il:* il:\; 
  "This situation is much simpler with backward jumps since both tag and jump are in the same units."
                                                           )
                                                     (setq min-distance (- (dtag-min-pc tag)
                                                                           (djump-min-pc jump)))
                                                     (setq max-distance (+ (- (dtag-pc-uncertainty
                                                                               tag)
                                                                              cumulative-uncertainty)
                                                                           min-distance))))
                                            (setq min-size (compute-jump-size kind min-distance))
                                            (setq max-size (compute-jump-size kind max-distance))
                                            (when (> min-size (djump-min-size jump))
                                                  (incf increase-in-min-pc (- min-size (
                                                                                       djump-min-size
                                                                                        jump)))
                                                  (setf (djump-min-size jump)
                                                        min-size))
                                            (let ((new-size-uncertainty (- max-size min-size)))
                                                 (when (/= (djump-size-uncertainty jump)
                                                           new-size-uncertainty)
                                                       (assert (>= new-size-uncertainty 0)
                                                              nil 
                                                              "The size uncertainty went negative")
                                                       (incf decrease-in-uncertainty
                                                             (- (djump-size-uncertainty jump)
                                                                new-size-uncertainty))
                                                       (setf (djump-size-uncertainty jump)
                                                             new-size-uncertainty))
                                                 (incf cumulative-uncertainty new-size-uncertainty)))
                                       ))))
            (il:* il:|;;| "If we've either got no uncertainty left in the system or didn't manage to achieve anything this pass, give it up; we're done."
                  )
            (not (or (zerop cumulative-uncertainty)
                     (zerop decrease-in-uncertainty)))))
(defun splice-in-jumps (jump-list)
       (il:for jump il:in jump-list il:do
              (if (dtag-p jump)
                  (setf (dtag-pc jump)
                        (dtag-min-pc jump))
                  (let* ((ptr (djump-ptr jump))
                         (tag (djump-tag jump))
                         (distance (- (dtag-min-pc tag)
                                      (djump-min-pc jump)))
                         (kind (djump-kind jump))
                         (size (compute-jump-size kind distance))
                         (choices (cdr (assoc kind +jump-choices+))))
                        (ecase size ((1)
                                     (il:* il:\; "One-byte jumps: JUMP, TJUMP, and FJUMP")
                                     (rplaca ptr (list (first choices)
                                                       (- distance 2))))
                               ((2)
                                (il:* il:\; 
                                      "Two-byte-jumps: JUMPX, FJUMPX, TJUMPX, NTJUMPX, and NFJUMPX")
                                (il:rplnode ptr (second choices)
                                       (cons (if (< distance 0)
                                                 (+ distance 256)
                                                 distance)
                                             (cdr ptr))))
                               ((3 4)
                                (il:* il:\; 
    "The three-byte jump is JUMPXX.  Four-byte jumps are like (FJUMP 4) JUMPXX to implement TJUMPXX."
                                      )
                                (cond ((= size 3)
                                       (rplaca ptr (third choices)))
                                      (t (rplaca ptr (third choices))
                                         (rplacd ptr (cons 'il:jumpxx (cdr ptr)))
                                         (setq ptr (cdr ptr))))
                                (rplacd ptr (cons (logand (il:lrsh distance 8)
                                                         255)
                                                  (cons (logand distance 255)
                                                        (cdr ptr)))))
                               ((6)
                                (il:* il:\; 
                        "Six-byte jumps are long NCJUMPXX's implemented by NCJUMPX 3 (JUMP 4) JUMPXX"
                                      )
                                (il:rplnode ptr (second choices)
                                       `(3 (il:jump 4)
                                           il:jumpxx
                                           ,(il:lrsh (- distance 3)
                                                   8)
                                           ,(logand (- distance 3)
                                                   255)
                                           ,@(cdr ptr)))))))))
(defun compute-jump-size (kind distance)
       (let ((pairs (cdr (assoc kind +jump-range-size-map+))))
            (il:find pair il:in pairs il:suchthat (< distance (car pair))
                   il:finally
                   (return (cdr pair)))))



(il:* il:\; "Debugging jump resolution")


(defun pretty-jumps nil (il:for jump-or-tag il:in (reverse *jump-list*)
                               il:collect
                               (etypecase jump-or-tag (dtag `(:tag :min-pc ,(dtag-min-pc jump-or-tag) 
                                                                   :pc-uncertainty
                                                                   ,(dtag-pc-uncertainty jump-or-tag)
                                                                   ))
                                      (djump `(,(djump-kind jump-or-tag)
                                               :min-pc
                                               ,(djump-min-pc jump-or-tag) :min-size
                                               ,(djump-min-size jump-or-tag) :forward-p
                                               ,(djump-forward-p jump-or-tag) :size-uncertainty
                                               ,(djump-size-uncertainty jump-or-tag) :tag
                                               (:min-pc ,(dtag-min-pc (djump-tag jump-or-tag))))))))



(il:* il:|;;| "Conversion to binary")


(defun
 convert-to-binary
 (byte-list)
 (let* ((codelen (length byte-list))
        (code-array (make-array codelen :element-type '(unsigned-byte 8)))
        (unwind-offset (+ (il:ceil (+ (dcode-nlocals *dcode*)
                                      (dcode-nfreevars *dcode*))
                                 il:cellsperquad)
                          il:cellsperquad)))
       (il:for byte il:in byte-list il:as code-index il:from 0 il:do
              (setf (aref code-array code-index)
                    (etypecase byte (symbol (il:* il:\; "Symbols represent real D-machine opcodes.")
                                           (il:fetch il:op# il:of (il:\\findop byte)))
                           ((unsigned-byte 8)
                            (il:* il:\; "Small integers generally represent themselves, usually either as arguments to opcodes or filler bytes for fixups."
                                  )
                            byte)
                           (cons (il:* il:\; 
                "Conses are either fixups or opcodes that take their argument inside their bytecode."
                                       )
                                 (case (first byte)
                                       ((sym)
                                        (push (list code-index (second byte))
                                              (dcode-sym-fixups *dcode*))
                                        0)
                                       ((lit)
                                        (push (list code-index (second byte))
                                              (dcode-lit-fixups *dcode*))
                                        0)
                                       ((fn)
                                        (push (list code-index (second byte))
                                              (dcode-fn-fixups *dcode*))
                                        0)
                                       ((type)
                                        (push (list code-index (second byte))
                                              (dcode-type-fixups *dcode*))
                                        0)
                                       ((lambda)
                                        (push (list code-index (dcode-from-dlambda (third byte)
                                                                      (second byte)))
                                              (dcode-lit-fixups *dcode*))
                                        0)
                                       ((unwind)
                                        (+ unwind-offset (second byte)))
                                       (otherwise (let ((range (il:fetch il:op# il:of
                                                                      (il:\\findop (first byte)))))
                                                       (assert (<= 0 (second byte)
                                                                (- (second range)
                                                                   (first range))))
                                                       (+ (first range)
                                                          (second byte)))))))))
       (setf (dcode-code-array *dcode*)
             code-array)))



(il:* il:|;;| "Setting up the debugging information")


(defun compute-debugging-info (dlambda)
       (setf (dcode-debugging-info *dcode*)
             `((,@(mapcar #'dvar-name (dlambda-required dlambda))
                ,@(and (dlambda-optional dlambda)
                       (cons '&optional (mapcar #'(lambda (opt-var)
                                                         (dvar-name (first opt-var))) (
                                                                                     dlambda-optional
                                                                                       dlambda))))
                ,@(and (dlambda-rest dlambda)
                       (not (eq :ignored (dlambda-rest dlambda)))
                       (list '&rest (dvar-name (dlambda-rest dlambda))))
                ,@(and (dlambda-key dlambda)
                       (cons '&key (mapcar #'first (dlambda-key dlambda))))
                ,@(and (dlambda-allow-other-keys dlambda)
                       '(&allow-other-keys))))))



(il:* il:|;;| "Fixup resolution and DCODE interning")


(defun allocate-code-block (nt-count code-len)
       (il:* il:|;;;| "Return a code-array that is large enough to hold a compiled function with a name-table NT-COUNT entries long and with CODE-LEN bytecodes.  Also return, as a second value, the index in that code-array of the place to put the first bytecode."
             )
       (let* ((nt-size (il:ceil (1+ nt-count)
                              il:wordsperquad))
              (nt-words (if (zerop nt-count)
                            il:wordsperquad
                            (+ nt-size nt-size)))
              (start-pc (* (+ (il:fetch (il:codearray il:overheadwords)
                                     il:of t)
                              nt-words il:wordspercell)
                           il:bytesperword))
              (total-size (il:ceil (+ start-pc code-len)
                                 il:bytesperquad))
              (code-base (il:\\alloc.code.block total-size (il:ceil (1+ (ceiling start-pc 
                                                                               il:bytespercell))
                                                                  il:cellsperquad))))
             (values code-base start-pc)))
(defun fixup-ptr (base offset ptr)
       (let ((low (il:\\loloc ptr)))
            (il:uninterruptably
                (il:\\addref ptr)
                (il:\\putbasebyte base offset (il:\\hiloc ptr))
                (il:\\putbasebyte base (+ 1 offset)
                       (il:lrsh low 8))
                (il:\\putbasebyte base (+ 2 offset)
                       (logand low 255)))
            ptr))
(defun fixup-word (base offset word)
       (il:\\putbasebyte base offset (il:lrsh word 8))
       (il:\\putbasebyte base (1+ offset)
              (logand word 255))
       word)
(defun intern-dcode (dcode &optional (copy-p (arrayp (dcode-code-array dcode))))
       (il:* il:|;;;| "NOTE: For unfortunately unavoidable performance reasons, this code is essentially duplicated in the FASL loader.  If you change something here, change it there as well.  And don't change anything unless you've got a pointy hat with a lot of stars on it."
             )
       (il:* il:|;;| "NTSIZE and NTBYTESIZE are the length of one-half of the name table in words and bytes, respectively.  NTWORDS is the length of the whole name table in words."
             )
       (let* ((name-table (dcode-name-table dcode))
              (ntsize (il:ceil (1+ (length name-table))
                             il:wordsperquad))
              (ntbytesize (* ntsize il:bytesperword))
              (ntwords (if (zerop (length name-table))
                           il:wordsperquad
                           (+ ntsize ntsize)))
              (overheadbytes (* (il:|fetch| (il:fnheader il:overheadwords)
                                       il:|of| t)
                                il:bytesperword))
              raw-code fvaroffset)
             (il:* il:|;;| "Copy the bytes into a raw code block if necessary.")
             (if (null copy-p)
                 (setq raw-code (dcode-code-array dcode))
                 (let ((code-array (dcode-code-array dcode)))
                      (multiple-value-bind (code-block start-index)
                             (allocate-code-block (length name-table)
                                    (length code-array))
                             (il:for ca-index il:from 0 il:to (1- (length code-array))
                                    il:as cb-index il:from start-index il:do (il:\\putbasebyte
                                                                              code-block cb-index
                                                                              (aref code-array 
                                                                                    ca-index)))
                             (setq raw-code code-block))))
             (il:* il:|;;| "Set up the free-variable lookup name table.")
             (do ((end (length name-table))
                  (i 0 (1+ i))
                  (index overheadbytes (+ index il:bytesperword)))
                 ((>= i end))
                 (let ((entry (elt name-table i)))
                      (fixup-word raw-code index (il:\\loloc (third entry)))
                      (fixup-word raw-code (+ index ntbytesize)
                             (+ (il:llsh (first entry)
                                       14)
                                (second entry)))
                      (when (and (null fvaroffset)
                                 (= (first entry)
                                    +fvar-code+))
                            (setq fvaroffset (floor index il:bytesperword)))))
             (il:* il:|;;| "Fill in the fixed-size fields at the front of the block.")
             (il:replace (il:fnheader il:na)
                    il:of raw-code il:with (dcode-num-args dcode))
             (il:replace (il:fnheader il:pv)
                    il:of raw-code il:with (1- (ceiling (+ (dcode-nlocals dcode)
                                                           (dcode-nfreevars dcode))
                                                      il:cellsperquad)))
             (il:* il:|;;| "The start-pc is after the fixed-size stuff, the name-table, and a cell in which to store the debugging info."
                   )
             (il:replace (il:fnheader il:startpc)
                    il:of raw-code il:with (+ overheadbytes (* ntwords il:bytesperword)
                                              il:bytespercell))
             (il:replace (il:fnheader il:argtype)
                    il:of raw-code il:with (dcode-arg-type dcode))
             (let ((frame-name (dcode-frame-name dcode)))
                  (il:uninterruptably
                      (il:\\addref frame-name)
                      (il:replace
 (il:fnheader il:\#framename) il:of
 raw-code il:with
 frame-name)))
             (il:replace (il:fnheader il:ntsize)
                    il:of raw-code il:with ntsize)
             (il:replace (il:fnheader il:nlocals)
                    il:of raw-code il:with (dcode-nlocals dcode))
             (il:replace (il:fnheader il:fvaroffset)
                    il:of raw-code il:with (or fvaroffset 0))
             (il:replace (il:fnheader il:closurep)
                    il:of raw-code il:with (eq :closure (dcode-closure-p dcode)))
             (il:replace (il:fnheader il:fixed)
                    il:of raw-code il:with t)
             (il:* il:|;;| "Fill in the debugging information and perform the fixups.  The + 1 here is to allow for the fact that four bytes are allocated for the debugging information, but pointers are only three bytes long, so we right-justify the pointer in the cell."
                   )
             (fixup-ptr raw-code (+ 1 overheadbytes (* ntwords il:bytesperword))
                    (dcode-debugging-info dcode))
             (let ((start-pc (il:fetch (il:fnheader il:startpc)
                                    il:of raw-code)))
                  (do ((end (length (dcode-fn-fixups dcode)))
                       (i 0 (1+ i)))
                      ((>= i end))
                      (il:destructuring-bind (offset item)
                             (elt (dcode-fn-fixups dcode)
                                  i)
                             (fixup-word raw-code (+ start-pc offset)
                                    (il:\\loloc item))))
                  (do ((end (length (dcode-sym-fixups dcode)))
                       (i 0 (1+ i)))
                      ((>= i end))
                      (il:destructuring-bind (offset item)
                             (elt (dcode-sym-fixups dcode)
                                  i)
                             (fixup-word raw-code (+ start-pc offset)
                                    (il:\\loloc item))))
                  (do ((end (length (dcode-lit-fixups dcode)))
                       (i 0 (1+ i)))
                      ((>= i end))
                      (il:destructuring-bind (offset item)
                             (elt (dcode-lit-fixups dcode)
                                  i)
                             (fixup-ptr raw-code (+ start-pc offset)
                                    (if (dcode-p item)
                                        (intern-dcode item)
                                        item))))
                  (do ((end (length (dcode-type-fixups dcode)))
                       (i 0 (1+ i)))
                      ((>= i end))
                      (il:destructuring-bind (offset item)
                             (elt (dcode-type-fixups dcode)
                                  i)
                             (fixup-word raw-code (+ start-pc offset)
                                    (il:\\resolve.typenumber item)))))
             (il:* il:|;;| "Finally, wrap this up in a closure-object if requested.")
             (if (eq :function (dcode-closure-p dcode))
                 (il:make-compiled-closure raw-code nil)
                 raw-code)))



(il:* il:|;;| "Arrange for the correct compiler to be used")



(il:putprops il:d-assem il:filetype
 compile-file)



(il:* il:|;;| "Arrange for the proper makefile environment")



(il:putprops il:d-assem il:makefile-environment
 (:readtable "XCL" :package (il:defpackage
                                                                            "D-ASSEM"
                                                                            (:use "LISP"))))
(il:declare\: il:eval@compile il:dontcopy 
(il:filesload (il:loadcomp)
       il:llbasic il:llcode il:llgc il:modarith)
)
(il:putprops il:d-assem il:copyright ("Xerox Corporation" 1986))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop