Function: byte-compile-lapcode

byte-compile-lapcode is a byte-compiled function defined in bytecomp.el.gz.

Signature

(byte-compile-lapcode LAP)

Documentation

Turn lapcode LAP into bytecode. The lapcode is destroyed.

Source Code

;; Defined in /usr/src/emacs/lisp/emacs-lisp/bytecomp.el.gz
(defun byte-compile-lapcode (lap)
  "Turn lapcode LAP into bytecode.  The lapcode is destroyed."
  ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
  (let ((pc 0)			; Program counter
	op off			; Operation & offset
	opcode			; numeric value of OP
	(bytes '())		; Put the output bytes here
	(patchlist nil))        ; List of gotos to patch
    (dolist (lap-entry lap)
      (setq op (car lap-entry)
	    off (cdr lap-entry))
      (cond
       ((not (symbolp op))
        (error "Non-symbolic opcode `%s'" op))
       ((eq op 'TAG)
        (setcar off pc))
       (t
        (setq opcode
              (if (eq op 'byte-discardN-preserve-tos)
                  ;; byte-discardN-preserve-tos is a pseudo op, which
                  ;; is actually the same as byte-discardN
                  ;; with a modified argument.
                  byte-discardN
                (symbol-value op)))
        (cond ((memq op byte-goto-ops)
               ;; goto
               (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
               (push bytes patchlist))
              ((or (and (consp off)
                        ;; Variable or constant reference
                        (progn
                          (setq off (cdr off))
                          (eq op 'byte-constant)))
                   (and (eq op 'byte-constant)
                        (integerp off)))
               ;; constant ref
               (if (< off byte-constant-limit)
                   (byte-compile-push-bytecodes (+ byte-constant off)
                                                bytes pc)
                 (byte-compile-push-bytecode-const2 byte-constant2 off
                                                    bytes pc)))
              ((and (= opcode byte-stack-set)
                    (> off 255))
               ;; Use the two-byte version of byte-stack-set if the
               ;; offset is too large for the normal version.
               (byte-compile-push-bytecode-const2 byte-stack-set2 off
                                                  bytes pc))
              ((and (>= opcode byte-listN)
                    (< opcode byte-discardN))
               ;; These insns all put their operand into one extra byte.
               (byte-compile-push-bytecodes opcode off bytes pc))
              ((= opcode byte-discardN)
               ;; byte-discardN is weird in that it encodes a flag in the
               ;; top bit of its one-byte argument.  If the argument is
               ;; too large to fit in 7 bits, the opcode can be repeated.
               (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0)))
                 (while (> off #x7f)
                   (byte-compile-push-bytecodes opcode (logior #x7f flag)
                                                bytes pc)
                   (setq off (- off #x7f)))
                 (byte-compile-push-bytecodes opcode (logior off flag)
                                              bytes pc)))
              ((null off)
               ;; opcode that doesn't use OFF
               (byte-compile-push-bytecodes opcode bytes pc))
              ((and (eq opcode byte-stack-ref) (eq off 0))
               ;; (stack-ref 0) is really just another name for `dup'.
               (debug)                 ;FIXME: When would this happen?
               (byte-compile-push-bytecodes byte-dup bytes pc))
              ;; The following three cases are for the special
              ;; insns that encode their operand into 0, 1, or 2
              ;; extra bytes depending on its magnitude.
              ((< off 6)
               (byte-compile-push-bytecodes (+ opcode off) bytes pc))
              ((< off 256)
               (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
              (t
               (byte-compile-push-bytecode-const2 (+ opcode 7) off
                                                  bytes pc))))))
    ;;(if (not (= pc (length bytes)))
    ;;    (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
    ;; Patch tag PCs into absolute jumps.
    (dolist (bytes-tail patchlist)
      (setq pc (caar bytes-tail))	; Pick PC from goto's tag.
      ;; Splits PC's value into 2 bytes. The jump address is
      ;; "reconstructed" by the `FETCH2' macro in `bytecode.c'.
      (setcar (cdr bytes-tail) (logand pc 255))
      (setcar bytes-tail (ash pc -8))
      ;; FIXME: Replace this by some workaround.
      (or (<= 0 (car bytes-tail) 255) (error "Bytecode overflow")))

    ;; Similarly, replace TAGs in all jump tables with the correct PC index.
    (dolist (hash-table byte-compile-jump-tables)
      (maphash #'(lambda (value tag)
                   (setq pc (cadr tag))
                   ;; We don't need to split PC here, as it is stored as a lisp
                   ;; object in the hash table (whereas other goto-* ops store
                   ;; it within 2 bytes in the byte string).
                   (puthash value pc hash-table))
               hash-table))
    (let ((bytecode (apply 'unibyte-string (nreverse bytes))))
      (when byte-native-compiling
        ;; Spill LAP for the native compiler here.
        (puthash bytecode (make-byte-to-native-lambda :lap lap)
                 byte-to-native-lambdas-h))
      bytecode)))