/lisp/compile.l
LEX | 2042 lines | 1864 code | 178 blank | 0 comment | 0 complexity | 927cb394aad6ac99151f2efc1bf3b58e MD5 | raw file
Possible License(s): BSD-3-Clause
Large files files are truncated, but you can click here to view the full file
- ;;; -*- Mode: Lisp; Package: COMPILER -*-
- ;;;
- ;;; This file is part of xyzzy.
- ;;;
- (provide "compile")
- ;;; OPE-CODES
- ;;; LEXICAL-REF: レキシカル変数の参照 (LEXICAL-REF (<SYMBOL> <SPECIAL-P> <REF-CLOSURE-P>))
- ;;; GLOBAL-REF: グローバル変数の参照 (GLOBAL-REF <SYMBOL>)
- ;;; LEXICAL-SET: レキシカル変数の設定 (LEXICAL-SET (<SYMBOL> <SPECIAL-P> <REF-CLOSURE-P>))
- ;;; GLOBAL-SET: グローバル変数の設定 (GLOBAL-SET <SYMBOL>)
- ;;; CONSTANT: 自己参照型 (CONSTANT <OBJECT>)
- ;;; CALL: 関数コール (CALL <FUNCTION> <NARGS>)
- ;;; DISCARD: スタックポインタを1- (DISCARD)
- ;;; GOTO: (GOTO <TAG>)
- ;;; IF-NIL-GOTO: stack[0]がnilならばgoto (IF-NIL-GOTO <TAG>)
- ;;; IF-NIL-GOTO-AND-POP: stack[0]がnilならばgoto (IF-NIL-GOTO-AND-POP <TAG>)
- ;;; IF-NON-NIL-GOTO: stack[0]がnon-nilならばgoto (IF-NON-NIL-GOTO <TAG>)
- ;;; IF-NON-NIL-GOTO-AND-POP: stack[0]がnon-nilならばgoto (IF-NON-NIL-GOTO-AND-POP <TAG>)
- ;;; LABEL: (LABEL <TAG>)
- ;;; RETURN: (RETURN <TAG>)
- ;;; GO: (GO <TAG>)
- ;;; ADJUST-STACK (ADJUST-STACK <STACK-DEPTH> <TAG>)
- ;;; BLOCK (BLOCK <TAG>)
- ;;; SPECIAL (SPECIAL <TAG> {<VAR>}*)
- ;;; SPECIAL-END
- ;;; MULTIPLE-VALUE-SET (MULTIPLE-VALUE-SET <COUNT>)
- ;;; MULTIPLE-VALUE-SET-END (MULTIPLE-VALUE-SET-END)
- ;;; LIST-MULTIPLE-VALUE
- ;;; CALL-MULTIPLE-VALUE
- ;;; SAVE-MULTIPLE-VALUE
- ;;; TAGBODY
- ;;; UNWIND-PROTECT
- ;;; CATCH
- ;;; THROW
- ;;; MAKE-CLOSURE
- ;;; SAVE-EXCURSION
- ;;; SAVE-RESTRICTION
- ;;; SAVE-WINDOW-EXCURSION
- ;;; OPTIMIZER
- ;;; SET - DISCARD - REF ---> SET
- ;;; SET - DISCARD ---> SET-DISCARD
- ;;; REF - DISCARD ---> none
- ;;; CONSTANT - DISCARD ---> none
- ;;; NULL/NOT NULL/NOT ---> none(無条件にやるのはまずい? まだやってないけど)
- ;;; NULL/NOT - IF-NIL-GOTO ---> IF-NON-NIL-GOTO (予定)
- ;;; NULL/NOT - IF-NON-NIL-GOTO ---> IF-NIL-GOTO (予定)
- ;;; jump optimize
- ;;; omit unreached code
- ;;; local return/go ---> GOTO
- ;;; constant folding
- (lisp:in-package "lisp")
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compile-file byte-compile-file
- byte-recompile-directory compile
- mc-compile-file mc-byte-compile-file
- mc-byte-recompile-directory)))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package "compiler")
- (defpackage "compiler"
- (:use "lisp" "editor")
- (:internal-size 200)
- (:external-size 10))))
- (in-package "compiler")
- (let ()
- ;; *MACRO-ENVIRONMENT*: defmacro(コンパイル単位)と
- ;; ローカルな関数・マクロのリスト
- (defvar *macro-environment* nil)
- ;; *SPECIAL-VARIABLES*: スペシャル変数のリスト(コンパイル単位)
- (defvar *special-variables* nil)
- ;; *CONSTANT-VARIABLES*: 定数変数のリスト(コンパイル単位)
- ;; (SYMBOL . VALUE)
- (defvar *constant-variables* nil)
- ;; *STACK-DEPTH*: 現在のスタックの深さ
- (defvar *stack-depth* 0)
- ;; *STACK-DEPTH-MAX*: 最大のスタックの深さ
- (defvar *stack-depth-max* 0)
- ;; *VARIABLE-LIST*: 束縛変数のリスト
- (defvar *variable-list* nil)
- ;; *BOUND-VARS*: 束縛変数のリスト
- (defvar *bound-vars* nil)
- ;; *STACK-FRAME-INDEX*:
- (defvar *stack-frame-index* 0)
- ;; *STACK-FRAME-MAX*: 同時に有効になる束縛変数の個数の最大値
- (defvar *stack-frame-max* 0)
- ;; *BLOCK-ENVIRONMENT*: block環境のリスト
- (defvar *block-environment* nil)
- ;; *TAGBODY-ENVIRONMENT*: tagbody環境のリスト
- (defvar *tagbody-environment* nil)
- ;; *INSN-LIST*: 中間コードのリスト
- (defvar *insn-list* nil)
- (defvar *compile-time-too* nil))
- (let ()
- (setf (get 'defun 'toplevel-macro) 'print-defun)
- (setf (get 'defmacro 'toplevel-macro) 'print-form)
- (setf (get 'defconstant 'toplevel-macro) 'print-form)
- (setf (get 'defvar 'toplevel-macro) 'print-form)
- (setf (get 'defparameter 'toplevel-macro) 'print-form)
- (setf (get 'defmacro 'compiler-effect) 'record-defmacro)
- (setf (get 'defconstant 'compiler-effect) 'record-defconstant)
- (setf (get 'defvar 'compiler-effect) 'record-defvar)
- (setf (get 'defparameter 'compiler-effect) 'record-defvar)
- (setf (get 'quote 'special-form) 'compile-quote)
- (setf (get 'function 'special-form) 'compile-function)
- (setf (get 'progn 'special-form) 'compile-progn)
- (setf (get 'let 'special-form) 'compile-let)
- (setf (get 'let* 'special-form) 'compile-let*)
- (setf (get 'if 'special-form) 'compile-if)
- (setf (get 'setq 'special-form) 'compile-setq)
- (setf (get 'block 'special-form) 'compile-block)
- (setf (get 'return-from 'special-form) 'compile-return-from)
- (setf (get 'tagbody 'special-form) 'compile-tagbody)
- (setf (get 'go 'special-form) 'compile-go)
- (setf (get 'unwind-protect 'special-form) 'compile-unwind-protect)
- (setf (get 'catch 'special-form) 'compile-catch)
- (setf (get 'throw 'special-form) 'compile-throw)
- (setf (get 'eval-when 'special-form) 'compile-eval-when)
- (setf (get 'multiple-value-call 'special-form) 'compile-multiple-value-call)
- (setf (get 'multiple-value-prog1 'special-form) 'compile-multiple-value-prog1)
- (setf (get 'multiple-value-bind 'special-form) 'compile-multiple-value-bind)
- (setf (get 'multiple-value-setq 'special-form) 'compile-multiple-value-setq)
- (setf (get 'save-excursion 'special-form) 'compile-save-excursion)
- (setf (get 'save-restriction 'special-form) 'compile-save-restriction)
- (setf (get 'save-window-excursion 'special-form) 'compile-save-window-excursion)
- (setf (get 'flet 'special-form) 'compile-flet)
- (setf (get 'labels 'special-form) 'compile-labels)
- (setf (get 'macrolet 'special-form) 'compile-macrolet)
- (setf (get '*compile-flet-bind 'special-form) '*compile-flet-bind))
- (defun byte-compile-file (filename)
- (interactive "fByte compile file: " :title0 "Byte compile file")
- (long-operation
- (compile-file filename)))
- (defun mc-byte-compile-file (filename &optional encoding)
- (interactive "fByte compile file: \n0zEncoding: " :title0 "Byte compile file")
- (long-operation
- (mc-compile-file filename encoding)))
- (defun byte-recompile-directory (dirname &optional arg)
- (interactive "DByte compile directory: \np")
- (byte-recompile-directory-1 dirname arg #'compile-file))
- (defun mc-byte-recompile-directory (dirname &optional arg)
- (interactive "DByte compile directory: \np")
- (byte-recompile-directory-1 dirname arg #'mc-compile-file))
- (defun byte-recompile-directory-1 (dirname arg compile-fn)
- (long-operation
- (let ((count 0))
- (dolist (src (mapcan #'(lambda (ext)
- (directory (merge-pathnames ext dirname) :absolute t))
- '("*.l" "*.lisp")))
- (let ((dst (compile-file-pathname src)))
- (when (if (file-exist-p dst)
- (file-newer-than-file-p src dst)
- (and arg (yes-no-or-cancel-p "~Aをコンパイルしますか?" src)))
- (funcall compile-fn src)
- (setq count (1+ count)))))
- (format t "Total ~[No~:;~:*~d~] file~:*~p compiled~%" count)
- count)))
- (defun compile-file (filename)
- (with-open-file (is filename :direction :input :if-does-not-exist :error)
- (compile-file-1 filename is)))
- (defun mc-compile-file (filename &optional encoding)
- (unless (file-exist-p filename)
- (error 'file-not-found
- :datum "ファイルが見つかりません"
- :pathname filename))
- (let (buffer)
- (unwind-protect
- (ed:save-excursion
- (setq buffer (ed:create-new-buffer " *compile file*"))
- (ed:set-buffer buffer)
- (let ((ed:*expected-fileio-encoding*
- (or encoding
- (ed::find-file-auto-encoding filename)
- ed:*expected-fileio-encoding*)))
- (declare (special ed:*expected-fileio-encoding*))
- (ed:insert-file-contents filename t)
- (compile-file-1 filename (ed:make-buffer-stream buffer)
- (cadr (assoc (ed:buffer-fileio-encoding) ed:*character-set-alist*
- :key #'symbol-value)))))
- (when buffer
- (ed:delete-buffer buffer)))))
- (defun compile-file-1 (filename is &optional encoding)
- (setq filename (namestring filename))
- (with-open-file (os (compile-file-pathname filename)
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (when encoding
- (format os ";;; -*- Mode: Lisp; Encoding: ~A; -*-~%" encoding))
- (let ((*macro-environment* nil)
- (*special-variables* nil)
- (*constant-variables* nil)
- (*compile-time-too* nil)
- (*package* *package*))
- (let ((eof (make-symbol "eof"))
- form)
- (while (setq form (read is nil eof))
- (if (eq form eof)
- (return))
- (let ((opackage *package*))
- (setq form (process-toplevel form))
- (let ((*package* opackage))
- (if (and (consp form)
- (eq (car form) 'progn))
- (dolist (f (cdr form))
- (unless (constant-variable-p f)
- (write f :stream os :escape t :circle t)
- (terpri os)))
- (unless (constant-variable-p form)
- (write form :stream os :escape t :circle t)
- (terpri os)))))))))
- (princ "done.\n")
- t)
- (defun compile (name &optional definition)
- (setq definition
- (coerce (or definition
- (setq definition (symbol-function name)))
- 'function))
- (cond ((compiled-function-p definition))
- ((and (listp definition)
- (eq (car definition) 'macro)))
- ((si:*closurep definition)
- (when (or (si:closure-variable definition)
- (si:closure-function definition)
- (si:closure-frame definition))
- (error "空でない環境で定義された関数はコンパイルできません"))
- (let ((*macro-environment* nil)
- (*special-variables* nil)
- (*constant-variables* nil)
- (*stack-depth* 0)
- (*stack-depth-max* 0)
- (*variable-list* nil)
- (*bound-vars* nil)
- (*stack-frame-index* 0)
- (*stack-frame-max* 0)
- (*block-environment* nil)
- (*tagbody-environment* nil)
- (*insn-list* nil)
- (form (si:closure-body definition)))
- (multiple-value-bind (decl intr nargs)
- (compile-lambda form)
- (setq definition
- (coerce `(lambda ,(cadr form) ,@decl ,@intr
- ,(output-bytecode
- (optimize-insn (nreverse *insn-list*))
- nargs))
- 'function)))))
- (t
- (error "~Sはコンパイルできません" definition)))
- (if (null name)
- definition
- (progn
- (setf (symbol-function name) definition)
- name)))
- (defun print-defun (f)
- (format t "Compiling ~S...~%" (cadr f)))
- (defun print-form (f)
- (format t "~S...~%" f))
- (defun record-defmacro (form)
- (when (special-form-p (cadr form))
- (error 'invalid-function :datum (cadr form)))
- (push (cons (cadr form)
- (cons 'macro (cddr form)))
- *macro-environment*)
- form)
- (defun record-defconstant (form)
- (let ((symbol (cadr form))
- (value (eval (caddr form))))
- (check-type symbol symbol)
- (unless (constantp symbol)
- (set symbol value))
- (push (cons symbol value) *constant-variables*)
- (push symbol *special-variables*)
- form))
- (defun record-defvar (form)
- (let ((symbol (cadr form)))
- (check-type symbol symbol)
- (push symbol *special-variables*)
- form))
- (defun output-insn (ope &rest args)
- (push (cons ope args) *insn-list*))
- (defun output-label (tag)
- (push (list 'insn-label tag) *insn-list*))
- (defun update-stack (l)
- (incf *stack-depth* l)
- (setq *stack-depth-max* (max *stack-depth* *stack-depth-max*)))
- ;;; VARが定数変数?
- (defun constant-variable-p (var)
- (or (constantp var)
- (assoc var *constant-variables* :test #'eq)))
- (defmacro bound-var-symbol (x) `(car ,x))
- (defmacro bound-var-special-p (x) `(cadr ,x))
- (defmacro bound-var-refered-from-closure-p (x) `(caddr ,x))
- (defmacro bound-var-stack-frame-index (x) `(cadddr ,x))
- ;;; VARがグローバルなスペシャル変数?
- (defun global-special-p (var)
- (or (si:*specialp var)
- (member var *special-variables* :test #'eq)))
- ;;; 変数を作る: (SYMBOL SPECIALP <closureから参照された?> <stack frameのインデックス>)
- (defun make-variable (var)
- (unless (symbolp var)
- (compile-error "Wrong type argument: ~S" var))
- (when (constant-variable-p var)
- (compile-error "Attempt to modify constant: ~S" var))
- (let ((x (list var nil nil nil)))
- (push x *variable-list*)
- x))
- ;;; 変数にスタックフレームのインデックスをセットする
- (defun make-stack-frame (vars)
- (dolist (var vars)
- (setf (bound-var-stack-frame-index var) *stack-frame-index*)
- (incf *stack-frame-index*))
- (setq *stack-frame-max* (max *stack-frame-max* *stack-frame-index*)))
- ;;; シンボルVARの値を得る。
- (defun compile-varref (var)
- (let ((closurep nil))
- (dolist (l *bound-vars* 'nil)
- (if (eq l 'closure)
- (setq closurep t)
- (let ((v (assoc var l :test #'eq)))
- (when v
- (if (bound-var-special-p v)
- (return))
- (output-insn 'insn-lexical-ref v)
- (if closurep
- (setf (bound-var-refered-from-closure-p v) 't))
- (return-from compile-varref)))))
- (if (constant-variable-p var)
- (let ((value (assoc var *constant-variables* :test #'eq)))
- (setq value (if value (cdr value) (symbol-value var)))
- (if (or (integerp value)
- (floatp value)
- (characterp value)
- (and (symbolp value)
- (symbol-package value)))
- (compile-constant value)
- (output-insn 'insn-global-ref var)))
- (output-insn 'insn-global-ref var))))
- ;;; シンボルVARに値をセットする
- (defun compile-varset (var)
- (check-type var symbol)
- (cond ((constant-variable-p var)
- (compile-error 'modify-constant :name var))
- ((let ((closurep nil))
- (dolist (l *bound-vars* 'nil)
- (if (eq l 'closure)
- (setq closurep t)
- (let ((v (assoc var l :test #'eq)))
- (when v
- (if (bound-var-special-p v)
- (return 'nil))
- (output-insn 'insn-lexical-set v)
- (if closurep
- (setf (bound-var-refered-from-closure-p v) 't))
- (return 't)))))))
- (t
- (output-insn 'insn-global-set var))))
- ;;; 自己評価フォームを出力
- (defun compile-constant (object)
- (output-insn 'insn-constant object))
- ;;; スペシャル宣言された束縛変数を集める。
- (defun process-declare (decl)
- (let ((decls '())
- (specials '()))
- (dolist (d decl)
- (dolist (l (cdr d))
- (if (eq (car l) 'special)
- (dolist (x (cdr l))
- (if (symbolp x)
- (push x decls))))))
- (dolist (v (car *bound-vars*))
- (when (global-special-p (car v))
- (push v specials)))
- (dolist (d decls)
- (unless (or (global-special-p d)
- (assoc d specials :test #'eq))
- (dolist (l *bound-vars*)
- (let ((v (assoc d l :test #'eq)))
- (when v
- (push v specials)
- (return))))))
- specials))
- ;;; スペシャル宣言された束縛変数にマークをつける。
- (defun mark-special-vars (specials)
- (dolist (v specials)
- (setf (bound-var-special-p v) 't)))
- ;;; ブロックを確立する: (<識別子> <TAG> <closureから参照された?>)
- (defun estab-block (name)
- (let ((x (list name (make-tag (gensym "BLOCK")) 'nil)))
- (output-insn 'insn-block x)
- (push x *block-environment*)))
- ;;; ブロックを解除する。
- (defun unestab-block ()
- (let ((x (pop *block-environment*)))
- (output-label (cadr x))))
- ;;; NAMEにマッチするブロックのTAGを返す。
- (defun find-block (name)
- (let ((closurep nil))
- (dolist (x *block-environment*)
- (cond ((eq x 'closure)
- (setq closurep t))
- ((eq (car x) name)
- (if closurep
- (setf (caddr x) t))
- (return-from find-block (values x closurep))))))
- (compile-error 'no-target :operation 'return-from :target name))
- ;;; タグを作る (<識別子> <stack-depth> <closureから参照された?>)
- (defun make-tag (&optional (name (gensym "TAG")))
- (list name *stack-depth* 'nil))
- ;;; NAMEにマッチするtabgodyのTAGを返す。
- (defun find-tagbody (name)
- (let ((closurep nil))
- (dolist (l *tagbody-environment*)
- (if (eq l 'closure)
- (setq closurep t)
- (let ((x (assoc name l :test #'eq)))
- (when x
- (if closurep
- (setf (caddr x) t))
- (return-from find-tagbody (values x closurep)))))))
- (compile-error 'no-target :operation 'go :target name))
- (defun parse-lambda-list (arglist)
- (let ((lambda-keys '(&optional &rest &key &aux))
- (vars '())
- arg)
- (while (setq arg (pop arglist))
- (if (member arg lambda-keys :test #'eq)
- (return))
- (push (make-variable arg) vars))
- (pop lambda-keys)
- (when (eq arg '&optional)
- (while (setq arg (pop arglist))
- (cond ((member arg lambda-keys :test #'eq)
- (return))
- ((symbolp arg)
- (push (make-variable arg) vars))
- ((consp arg)
- (push (make-variable (car arg)) vars)
- (when (caddr arg)
- (push (make-variable (caddr arg)) vars)))
- (t
- (compile-error 'type-error
- :datum arg
- :expected-type '(or symbol cons))))))
- (pop lambda-keys)
- (when (eq arg '&rest)
- (setq arg (pop arglist))
- (push (make-variable arg) vars)
- (setq arg (pop arglist)))
- (pop lambda-keys)
- (when (eq arg '&key)
- (while (setq arg (pop arglist))
- (cond ((member arg lambda-keys :test #'eq)
- (return))
- ((symbolp arg)
- (push (make-variable arg) vars))
- ((consp arg)
- (cond ((symbolp (car arg))
- (push (make-variable (car arg)) vars))
- ((consp (car arg))
- (push (make-variable (cadar arg)) vars))
- (t
- (compile-error 'type-error
- :expected-type '(or symbol cons)
- :datum (car arg))))
- (when (caddr arg)
- (push (make-variable (caddr arg)) vars)))
- (t
- (compile-error 'type-error
- :expected-type '(or symbol cons)
- :datum arg)))))
- (when (eq arg '&aux)
- (while (setq arg (pop arglist))
- (cond ((symbolp arg)
- (push (make-variable arg) vars))
- ((consp arg)
- (push (make-variable (car arg)) vars))
- (t
- (compile-error 'type-error
- :expected-type '(or symbol cons)
- :datum arg)))))
- vars))
- (defun compile-lambda (form)
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cddr form))
- (multiple-value-bind (intr body)
- (lisp::find-interactive body)
- (let* ((*stack-frame-index* *stack-frame-index*)
- (args (parse-lambda-list (cadr form)))
- (nargs (length args)))
- (push args *bound-vars*)
- (make-stack-frame args)
- (mark-special-vars (process-declare decl))
- (compile-progn body)
- (pop *bound-vars*)
- (values decl intr nargs)))))
- (defun compile-closure (form)
- (let ((*stack-depth* 0)
- (*stack-depth-max* 0)
- (*stack-frame-index* 0)
- (*stack-frame-max* 0)
- (*insn-list* nil)
- decl
- intr
- nargs
- insn)
- (push 'closure *tagbody-environment*)
- (push 'closure *block-environment*)
- (push 'closure *bound-vars*)
- (multiple-value-setq (decl intr nargs) (compile-lambda form))
- (pop *bound-vars*)
- (pop *block-environment*)
- (pop *tagbody-environment*)
- (setq insn (optimize-insn (nreverse *insn-list*)))
- `(lambda ,(cadr form) ,@decl ,@intr ,(output-bytecode insn nargs))))
- (defun compile-toplevel (fn form)
- (cond ((eq (car form) 'quote)
- form)
- ((and (eq (car form) 'function)
- (symbolp (cadr form)))
- form)
- (t
- (let ((*stack-depth* 0)
- (*stack-depth-max* 0)
- (*variable-list* nil)
- (*bound-vars* nil)
- (*stack-frame-index* 0)
- (*stack-frame-max* 0)
- (*block-environment* nil)
- (*tagbody-environment* nil)
- (*insn-list* nil))
- (compile-form form)
- (output-bytecode (optimize-insn (nreverse *insn-list*)) 0)))))
- (defun process-toplevel (f)
- (cond ((or (atom f)
- (not (symbolp (car f))))
- f)
- ((eq (car f) 'progn)
- (setq f (mapcan #'(lambda (x)
- (setq x (process-toplevel x))
- (if x (list x)))
- (cdr f)))
- (if (endp (cdr f))
- (car f)
- (cons 'progn f)))
- ((eq (car f) 'eval-when)
- (cond ((endp (cdr f))
- (compile-error "EVAL-WHENフォームの形式が不正です: ~S" f))
- ((or (member :load-toplevel (cadr f) :test #'eq)
- (member 'load (cadr f) :test #'eq))
- (let ((*compile-time-too*
- (or (member :compile-toplevel (cadr f) :test #'eq)
- (member 'compile (cadr f) :test #'eq)
- (and (or (member :execute (cadr f) :test #'eq)
- (member 'eval (cadr f) :test #'eq))
- *compile-time-too*))))
- (process-toplevel (cons 'progn (cddr f)))))
- ((or (member :compile-toplevel (cadr f) :test #'eq)
- (member 'compile (cadr f) :test #'eq)
- (and (or (member :execute (cadr f) :test #'eq)
- (member 'eval (cadr f) :test #'eq))
- *compile-time-too*))
- (mapc #'eval (cddr f))
- nil)
- (t nil)))
- ((eq (car f) 'quote)
- f)
- (t
- (let (tem)
- (and (setq tem (get (car f) 'toplevel-macro))
- (funcall tem f))
- (and (setq tem (get (car f) 'compiler-effect))
- (funcall tem f))
- (setq tem (macroexpand-1 f *macro-environment*))
- (unless (eq tem f)
- (return-from process-toplevel (process-toplevel tem)))
- (if *compile-time-too*
- (eval f))
- (setq tem (get (car f) 'special-form))
- (if tem
- (compile-toplevel tem f)
- (cons (car f)
- (mapcar #'(lambda (x)
- (if (and (consp x)
- (symbolp (car x))
- (get (car x) 'special-form))
- (compile-toplevel (get (car x) 'special-form) x)
- x))
- (cdr f))))))))
- (defun compile-call (form)
- (let ((f (assoc (car form) *macro-environment* :test #'eq)))
- (cond ((null f)
- (when (and (consp (car form))
- (eq (caar form) 'lambda))
- (push 'funcall form))
- (dolist (f (cdr form))
- (compile-form f))
- (output-insn 'insn-call (car form) (- (length form) 1)))
- ((symbolp (cdr f))
- (compile-form (cdr f))
- (dolist (f (cdr form))
- (compile-form f))
- (output-insn 'insn-call 'funcall (length form)))
- (t
- (compile-error "不正な関数コールです: ~S" form)))))
- (defun compile-form (form)
- (let ((ostack *stack-depth*))
- (cond ((symbolp form)
- (compile-varref form))
- ((consp form)
- (if (symbolp (car form))
- (let ((tem (get (car form) 'special-form)))
- (cond (tem
- (funcall tem (cdr form)))
- (t
- (and (setq tem (get (car form) 'compiler-effect))
- (funcall tem form))
- (multiple-value-setq (form tem)
- (macroexpand-1 form *macro-environment*))
- (if tem
- (compile-form form)
- (progn
- (and (null (assoc (car form) *macro-environment*
- :test #'eq))
- (setq tem (get (car form) 'optimize-form))
- (setq form (funcall tem form)))
- (compile-call form))))))
- (compile-call form)))
- (t
- (compile-constant form)))
- (setq *stack-depth* ostack)
- (update-stack 1)))
- (defun compile-setq (form)
- (if (null form)
- (compile-form nil)
- (do ((f form (cddr f)))
- ((endp f))
- (cond ((endp (cdr f))
- (compile-error 'too-few-arguments))
- (t
- (compile-form (cadr f))
- (compile-varset (car f))
- (unless (endp (cddr f))
- (decf *stack-depth*)
- (output-insn 'insn-discard)))))))
- (defun compile-progn (form)
- (compile-form (car form))
- (dolist (x (cdr form))
- (decf *stack-depth*)
- (output-insn 'insn-discard)
- (compile-form x)))
- (defun compile-let (form)
- (if (endp form)
- (compile-error "LETフォームの形式が不正です: ~S" form))
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr form))
- (let ((*stack-frame-index* *stack-frame-index*)
- (varlist (car form))
- (vars '())
- (tag (make-tag (gensym "LET"))))
- (dolist (var varlist)
- (compile-form (if (consp var) (cadr var) 'nil)))
- (dolist (var varlist)
- (push (make-variable (if (consp var) (car var) var)) vars))
- (output-insn 'insn-lexical-bind (cons tag vars))
- (push vars *bound-vars*)
- (make-stack-frame vars)
- (dolist (var (reverse varlist))
- (compile-varset (if (consp var) (car var) var))
- (output-insn 'insn-discard))
- (decf *stack-depth* (length varlist))
- (let ((specials (process-declare decl)))
- (if specials
- (progn
- (output-insn 'insn-special (list* tag specials))
- (dolist (v specials)
- (compile-varref (bound-var-symbol v)))
- (output-insn 'insn-special-end)
- (mark-special-vars specials)
- (compile-progn body))
- (compile-progn body)))
- (output-label tag)
- (pop *bound-vars*))))
- ;;;(defun compile-let* (form)
- ;;; (if (endp form)
- ;;; (compile-error "LET*フォームの形式が不正です: ~S" form))
- ;;; (multiple-value-bind (decl body)
- ;;; (lisp::find-declaration (cdr form))
- ;;; (let ((*stack-frame-index* *stack-frame-index*)
- ;;; (varlist (car form))
- ;;; (vars '())
- ;;; (tag (make-tag (gensym "LET"))))
- ;;; (push 'nil *bound-vars*)
- ;;; (dolist (var varlist)
- ;;; (push (make-variable (if (consp var) (car var) var)) vars))
- ;;; (setq vars (nreverse vars))
- ;;; (output-insn 'insn-lexical-bind (cons tag vars))
- ;;; (dolist (var varlist)
- ;;; (compile-form (if (consp var) (cadr var) 'nil))
- ;;; (push (pop vars) (car *bound-vars*))
- ;;; (decf *stack-depth*)
- ;;; (compile-varset (if (consp var) (car var) var))
- ;;; (output-insn 'insn-discard))
- ;;; (make-stack-frame (car *bound-vars*))
- ;;; (let ((specials (process-declare decl)))
- ;;; (if specials
- ;;; (progn
- ;;; (output-insn 'insn-special (list* tag specials))
- ;;; (dolist (v specials)
- ;;; (compile-varref (bound-var-symbol v)))
- ;;; (output-insn 'insn-special-end)
- ;;; (mark-special-vars specials)
- ;;; (compile-progn body))
- ;;; (compile-progn body)))
- ;;; (output-label tag)
- ;;; (pop *bound-vars*))))
- (defun compile-let* (form)
- (if (endp form)
- (compile-error "LET*フォームの形式が不正です: ~S" form))
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr form))
- (let ((*stack-frame-index* *stack-frame-index*)
- (varlist (car form))
- (vars '())
- (tag (make-tag (gensym "LET"))))
- (push 'nil *bound-vars*)
- (dolist (var varlist)
- (push (make-variable (if (consp var) (car var) var)) vars))
- (setq vars (nreverse vars))
- (output-insn 'insn-lexical-bind (cons tag vars))
- (dolist (var varlist)
- (compile-form (if (consp var) (cadr var) 'nil))
- (let ((v (pop vars)))
- (push v (car *bound-vars*))
- (decf *stack-depth*)
- (compile-varset (if (consp var) (car var) var))
- (output-insn 'insn-discard)
- (make-stack-frame (list v))))
- (let ((specials (process-declare decl)))
- (if specials
- (progn
- (output-insn 'insn-special (list* tag specials))
- (dolist (v specials)
- (compile-varref (bound-var-symbol v)))
- (output-insn 'insn-special-end)
- (mark-special-vars specials)
- (compile-progn body))
- (compile-progn body)))
- (output-label tag)
- (pop *bound-vars*))))
- (defun compile-multiple-value-bind (form)
- (if (or (endp form)
- (endp (cdr form)))
- (compile-error "MULTIPLE-VALUE-BINDフォームの形式が不正です: ~S" form))
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cddr form))
- (let ((*stack-frame-index* *stack-frame-index*)
- (varlist (car form))
- (vars '())
- (tag (make-tag (gensym "MULTIPLE-VALUE-BIND"))))
- (compile-form (cadr form)) ; compile values-form
- (dolist (var varlist)
- (push (make-variable var) vars))
- (output-insn 'insn-lexical-bind (cons tag vars))
- (push vars *bound-vars*)
- (make-stack-frame vars)
- (output-insn 'insn-multiple-value-set (length vars))
- (dolist (var varlist)
- (compile-varset (if (consp var) (car var) var)))
- (output-insn 'insn-multiple-value-set-end)
- (output-insn 'insn-discard)
- (decf *stack-depth*)
- (let ((specials (process-declare decl)))
- (if specials
- (progn
- (output-insn 'insn-special (list* tag specials))
- (dolist (v specials)
- (compile-varref (bound-var-symbol v)))
- (output-insn 'insn-special-end)
- (mark-special-vars specials)
- (compile-progn body))
- (compile-progn body)))
- (output-label tag)
- (pop *bound-vars*))))
- (defun compile-multiple-value-setq (form)
- (if (or (endp form)
- (not (listp form))
- (endp (cdr form)))
- (compile-error "MULTIPLE-VALUE-SETQフォームの形式が不正です: ~S" form))
- (compile-form (cadr form)) ; compile values-form
- (output-insn 'insn-multiple-value-set (length (car form)))
- (dolist (var (car form))
- (compile-varset var))
- (output-insn 'insn-multiple-value-set-end))
- (defun compile-multiple-value-call (form)
- (if (endp form)
- (compile-error "MULTIPLE-VALUE-CALLフォームの形式が不正です: ~S" form))
- (compile-form (car form))
- (compile-form 'nil)
- (dolist (f (cdr form))
- (compile-form f)
- (decf *stack-depth*)
- (output-insn 'insn-list-multiple-value))
- ;(decf *stack-depth*)
- (output-insn 'insn-call-multiple-value))
- (defun compile-multiple-value-prog1 (form)
- (if (endp form)
- (compile-error "MULTIPLE-VALUE-PROG1フォームの形式が不正です: ~S" form))
- (let ((end-tag (make-tag (gensym "MV-PROG1"))))
- (compile-form (car form))
- (output-insn 'insn-save-multiple-value end-tag)
- (compile-progn (cdr form))
- ;(decf *stack-depth*)
- (output-insn 'insn-discard)
- (output-label end-tag)))
- (defun compile-tagbody (form)
- (let ((end-tag (make-tag (gensym "TAGBODY")))
- tags)
- (dolist (f form)
- (if (or (integerp f) (symbolp f))
- (push (make-tag f) tags)))
- (push tags *tagbody-environment*)
- (output-insn 'insn-tagbody end-tag tags)
- (dolist (f form)
- (if (or (integerp f) (symbolp f))
- (output-label (assoc f tags :test #'eq))
- (progn
- (compile-form f)
- (decf *stack-depth*)
- (output-insn 'insn-discard))))
- (pop *tagbody-environment*)
- (compile-form 'nil)
- (output-label end-tag)))
- (defun compile-go (form)
- (if (or (endp form)
- (not (endp (cdr form))))
- (compile-error "TAGBODYフォームの形式が不正です: ~S" form))
- (multiple-value-bind (goal closurep)
- (find-tagbody (car form))
- (if closurep
- (output-insn 'insn-go goal)
- (progn
- (unless (= (cadr goal) *stack-depth*)
- (output-insn 'insn-adjust-stack (cadr goal)))
- (output-insn 'insn-goto goal)))))
- (defun compile-block (form)
- (if (endp form)
- (compile-error "BLOCKフォームの形式が不正です: ~S" form))
- (check-type (car form) symbol)
- (estab-block (car form))
- (compile-progn (cdr form))
- (unestab-block))
- (defun compile-return-from (form)
- (if (endp form)
- (compile-error "RETURN-FROMフォームの形式が不正です: ~S" form))
- (check-type (car form) symbol)
- (multiple-value-bind (goal closurep)
- (find-block (car form))
- (when (and (not closurep)
- (/= (cadadr goal) *stack-depth*))
- (setq *stack-depth* (cadadr goal))
- (output-insn 'insn-adjust-stack *stack-depth*))
- (cond ((endp (cdr form))
- (compile-form 'nil))
- ((endp (cddr form))
- (compile-form (cadr form)))
- (t
- (compile-error "RETURN-FROMフォームの形式が不正です: ~S" form)))
- (if closurep
- (output-insn 'insn-return goal)
- (output-insn 'insn-goto (cadr goal)))))
- (defun compile-if (form)
- (let ((l (length form)))
- (cond ((= l 2)
- (let ((donetag (make-tag)))
- (compile-form (car form))
- (output-insn 'insn-if-nil-goto donetag)
- (decf *stack-depth*)
- (compile-form (cadr form))
- (output-label donetag)))
- ((= l 3)
- (let ((elsetag (make-tag))
- (donetag (make-tag)))
- (compile-form (car form))
- (output-insn 'insn-if-nil-goto-and-pop elsetag)
- (decf *stack-depth*)
- (compile-form (cadr form))
- (output-insn 'insn-goto donetag)
- (decf *stack-depth*)
- (output-label elsetag)
- (compile-form (caddr form))
- (output-label donetag)))
- (t
- (compile-error "IFフォームの形式が不正です: ~S" form)))))
- (defun compile-quote (form)
- (unless (= (length form) 1)
- (compile-error "QUOTEフォームの形式が不正です: ~S" form))
- (compile-constant (car form)))
- (defun compile-unwind-protect (form)
- (if (endp form)
- (compile-error "UNWIND-PROTECTフォームの形式が不正です: ~S" form))
- (let ((ctag (make-tag (gensym "CLEANUP")))
- (ptag (make-tag (gensym "PROTECT"))))
- (output-insn 'insn-unwind-protect ctag ptag)
- (compile-form (car form))
- (output-label ctag)
- (compile-progn (cdr form))
- ;(decf *stack-depth*)
- (output-insn 'insn-discard) ; ???
- (output-label ptag)))
- (defun compile-catch (form)
- (if (endp form)
- (compile-error "CATCHフォームの形式が不正です: ~S" form))
- (compile-form (car form))
- (decf *stack-depth*)
- (let ((tag (make-tag (gensym "CATCH"))))
- (output-insn 'insn-catch tag)
- (compile-progn (cdr form))
- (output-label tag)))
- (defun compile-throw (form)
- (if (/= (length form) 2)
- (compile-error "THROWフォームの形式が不正です: ~S" form))
- (compile-form (cadr form))
- (compile-form (car form))
- ;;(decf *stack-depth*)
- (output-insn 'insn-throw))
- (defun compile-eval-when (form)
- (if (endp form)
- (compile-error "EVAL-WHENフォームの形式が不正です: ~S" form))
- ;;(incf *stack-depth*)
- (if (or (member ':execute (car form) :test #'eq)
- (member 'eval (car form) :test #'eq))
- (compile-progn (cdr form))
- (compile-form 'nil)))
- (defun compile-function (form)
- (unless (= (length form) 1)
- (compile-error "FUNCTIONフォームの形式が不正です: ~S" form))
- ;;(incf *stack-depth*)
- (cond ((symbolp (car form))
- (let ((f (assoc (car form) *macro-environment* :test #'eq)))
- (cond ((null f)
- (output-insn 'insn-function-symbol (car form)))
- ((symbolp (cdr f))
- (compile-form (cdr f)))
- (t
- (compile-error 'invalid-function
- :datum (car form))))))
- ((and (consp (car form))
- (eq (caar form) 'lambda))
- (output-insn 'insn-make-closure
- (compile-closure (car form))))
- (t
- (compile-error 'invalid-function :datum (car form)))))
- (defun flet-temp-vars (fnam form)
- (when (or (endp form)
- (endp (cdr form)))
- (compile-error "~Aフォームの形式が不正です: ~S" fnam form))
- (let ((env-vars '())
- (bind-forms '()))
- (dolist (def (car form))
- (when (or (endp def)
- (endp (cdr def)))
- (compile-error "~Aフォームの形式が不正です: ~S" fnam def))
- (let ((name (car def))
- (body (cdr def)))
- (unless (symbolp name)
- (compile-error "関数名が不正です: ~S" name))
- (when (or (endp body)
- (not (listp (car body))))
- (compile-error "不正な関数です: ~S" body))
- (let ((lambda-list (car body)))
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr body))
- (if (eq fnam 'macrolet)
- (push (cons name `(macro ,lambda-list ,@decl (block ,name ,@body)))
- env-vars)
- (let ((temp (gensym)))
- (push (cons name temp) env-vars)
- (multiple-value-bind (intr body)
- (lisp::find-interactive body)
- (push `(,temp #'(lambda ,lambda-list ,@decl ,@intr (block ,name ,@body)))
- bind-forms))))))))
- (values env-vars bind-forms)))
- ;;; DO NOT CALL THIS FUNCTION.
- (defun *compile-flet-bind (vars)
- (setq *macro-environment* (append (car vars) *macro-environment*))
- (compile-form 'nil))
- (defun compile-flet-unbind (vars)
- (dolist (x vars)
- (setq *macro-environment* (delete x *macro-environment* :test #'eq))))
- (defun compile-flet (form)
- (multiple-value-bind (env-vars bind-forms)
- (flet-temp-vars 'flet form)
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr form))
- (compile-form `(let ,bind-forms
- (*compile-flet-bind ,env-vars)
- ,@body)))
- (compile-flet-unbind env-vars)))
- (defun compile-labels (form)
- (multiple-value-bind (env-vars bind-forms)
- (flet-temp-vars 'labels form)
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr form))
- (compile-form `(let ,(mapcar #'car bind-forms)
- (*compile-flet-bind ,env-vars)
- ,@(mapcar #'(lambda (x) (cons 'setq x)) bind-forms)
- ,@body)))
- (compile-flet-unbind env-vars)))
- (defun compile-macrolet (form)
- (let ((vars (flet-temp-vars 'macrolet form)))
- (setq *macro-environment* (append vars *macro-environment*))
- (multiple-value-bind (decl body)
- (lisp::find-declaration (cdr form))
- (compile-progn body))
- (compile-flet-unbind vars)))
- (defun compile-save-excursion (form)
- (let ((end-tag (make-tag (gensym "SAVE-EXCURSION"))))
- (output-insn 'insn-save-excursion end-tag)
- (compile-progn form)
- (output-label end-tag)))
- (defun compile-save-restriction (form)
- (let ((end-tag (make-tag (gensym "SAVE-RESTRICTION"))))
- (output-insn 'insn-save-restriction end-tag)
- (compile-progn form)
- (output-label end-tag)))
- (defun compile-save-window-excursion (form)
- (let ((end-tag (make-tag (gensym "SAVE-WINDOW-EXCURSION"))))
- (output-insn 'insn-save-window-excursion end-tag)
- (compile-progn form)
- (output-label end-tag)))
- (defun compile-error (&rest r)
- (apply #'error r))
- ;;; optimize
- (defun remove-nil-insns (insn)
- (mapcan #'(lambda (x) (if x (list x))) insn))
- ;;; closureから参照されないlet/block/tagbodyを削除する。
- (defun remove-local-lexicals (insn)
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (or (and (eq (caar i) 'insn-block)
- (not (caddr (cadar i))))
- (and (eq (caar i) 'insn-tagbody)
- (not (setf (caddar i)
- (let ((tags '()))
- (dolist (x (caddar i) tags)
- (when (caddr x)
- (push x tags)))))))
- (and (eq (caar i) 'insn-lexical-bind)
- (not (setf (cdadar i)
- (let ((vars '()))
- (dolist (x (cdadar i) vars)
- (when (bound-var-refered-from-closure-p x)
- (push x vars))))))))
- (setf (car i) 'nil)
- (setq mod t)))
- (if mod
- (remove-nil-insns insn)
- insn)))
- (defun remove-duplicate-labels (insn)
- (do ((i insn (cdr i)))
- ((endp i))
- (when (eq (caar i) 'insn-label)
- (setf (cdr i)
- (do* ((j (cdr i) (cdr j))
- (op (car j) (car j)))
- ((or (endp j)
- (not (eq (car op) 'insn-label)))
- j)
- (nsubst (cadar i) (cadr op) insn :test #'eq)))))
- insn)
- (let ()
- (setf (get 'insn-goto 'jump) 't)
- (setf (get 'insn-if-nil-goto 'jump) 't)
- (setf (get 'insn-if-nil-goto 'if-nil-goto) 't)
- (setf (get 'insn-if-non-nil-goto 'jump) 't)
- (setf (get 'insn-if-nil-goto-and-pop 'jump) 't)
- (setf (get 'insn-if-nil-goto-and-pop 'if-nil-goto) 't)
- (setf (get 'insn-if-nil-goto-and-pop 'goto-and-pop) 't)
- (setf (get 'insn-if-non-nil-goto-and-pop 'jump) 't)
- (setf (get 'insn-if-non-nil-goto-and-pop 'goto-and-pop) 't))
- ;;; ジャンプを最適化
- (defun optimize-jump (insn)
- (let ((continue 't))
- (while continue
- (setq continue 'nil)
- (do ((i insn (cdr i)))
- ((endp i))
- (when (eq (caar i) 'insn-label)
- (cond ((eq (caadr i) 'insn-goto)
- ;; ラベルの直後が無条件ジャンプ(A)のとき、そのラベルを参照している
- ;; ジャンプ(B)を無条件ジャンプ(A)の飛び先に変更する。
- (let ((label (cadadr i)))
- (dolist (j insn)
- (when (and (get (car j) 'jump)
- (eq (cadr j) (cadar i))
- (not (eq j (cadr i))))
- (setf (cadr j) label)
- (setq continue 't)))))
- ((get (caadr i) 'jump)
- ;; ラベルの直後が条件ジャンプ(A)のとき、そのラベルを参照している同一の
- ;; 条件ジャンプ(B)を条件ジャンプ(A)の飛び先に変更する。
- ;; ・条件ジャンプ(A)がgoto-and-popならば条件ジャンプ(B)のオペコードも
- ;; 条件ジャンプ(A)と同じものに変更する。
- ;; ・条件ジャンプ(A)がgoto-and-popでないならば条件ジャンプ(B)がgoto-and-pop
- ;; でない場合のみ。
- (let* ((ope (caadr i))
- (label (cadadr i))
- (ope-if-nil-goto (get ope 'if-nil-goto))
- (ope-goto-and-pop (get ope 'goto-and-pop)))
- (dolist (j insn)
- (when (and (get (car j) 'jump)
- (eq (cadr j) (cadar i))
- (not (eq j (cadr i)))
- (eq (get (car j) 'if-nil-goto) ope-if-nil-goto))
- (cond (ope-goto-and-pop
- (setf (car j) ope)
- (setf (cadr j) label)
- (setq continue 't))
- ((not (get (car j) 'goto-and-pop))
- (setf (cadr j) label)
- (setq continue 't))))))))))))
- ;; 次の行へのジャンプを削除する。
- ;; ただし条件ジャンプの場合、
- ;; ・goto-and-popの場合はdiscardへ変更する。
- ;; ・goto-and-popでない場合はなにもしない。
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (and (get (caar i) 'jump)
- (eq (caadr i) 'insn-label)
- (eq (cadar i) (cadadr i)))
- (cond ((eq (caar i) 'insn-goto)
- (setf (car i) 'nil)
- (setq mod t))
- ((get (caar i) 'goto-and-pop)
- (setf (car i) '(insn-discard))))))
- (if mod
- (remove-nil-insns insn)
- insn)))
- ;;; 未参照ラベルを削除
- (defun remove-unreferenced-label (insn)
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (eq (caar i) 'insn-label)
- (let ((save (car i)))
- (setf (car i) nil)
- (if (si:*tree-find (cadr save) insn :test #'eq)
- (setf (car i) save)
- (setq mod t)))))
- (if mod
- (remove-nil-insns insn)
- insn)))
- (let ()
- (setf (get 'insn-goto 'no-cond-jump) 't)
- (setf (get 'insn-go 'no-cond-jump) 't)
- (setf (get 'insn-return 'no-cond-jump) 't))
- ;;; 未参照コードを削除
- (defun remove-unreferenced-code (insn)
- (do ((i insn (cdr i)))
- ((endp i) insn)
- (when (get (caar i) 'no-cond-jump)
- (setf (cdr i) (member 'insn-label (cdr i) :test #'eq :key #'car)))))
- (defun optimize-set-discard-ref (insn)
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (and (eq (caadr i) 'insn-discard)
- (or (and (eq (caar i) 'insn-lexical-set)
- (eq (caaddr i) 'insn-lexical-ref))
- (and (eq (caar i) 'insn-global-ref)
- (eq (caaddr i) 'insn-global-ref)))
- (eq (cadar i) (car (cdaddr i))))
- (setf (cadr i) 'nil)
- (setf (caddr i) 'nil)
- (setq mod t)))
- (if mod
- (remove-nil-insns insn)
- insn)))
- (defun optimize-set-discard (insn)
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (eq (caadr i) 'insn-discard)
- (cond ((eq (caar i) 'insn-lexical-set)
- (setf (caar i) 'insn-lexical-set-discard)
- (setf (cadr i) 'nil)
- (setq mod t))
- ((eq (caar i) 'insn-global-set)
- (setf (caar i) 'insn-global-set-discard)
- (setf (cadr i) 'nil)
- (setq mod t)))))
- (if mod
- (remove-nil-insns insn)
- insn)))
- (defun remove-ref-discard (insn)
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (when (and (or (eq (caar i) 'insn-lexical-ref)
- (eq (caar i) 'insn-global-ref)
- (eq (caar i) 'insn-constant))
- (eq (caadr i) 'insn-discard))
- (setf (car i) 'nil)
- (setf (cadr i) 'nil)
- (setq mod t)))
- (if mod
- (remove-nil-insns insn)
- insn)))
- ;; 定数の畳み込み
- ;; 副作用がなく1引数または2引数で多値を返さない数値演算関数のみ
- (dolist (x '(zerop plusp minusp oddp evenp
- = /= < > <= >= + - * /
- max min conjugate
- gcd lcm isqrt
- exp log sqrt abs
- sin cos tan asin acos atan
- signum float rational complex realpart imagpart
- rationalize numerator denominator
- float-radix float-sign float-digits float-precision
- lognot logcount logand logior logxor logeqv
- cis phase sinh cosh tanh asinh acosh atanh))
- (setf (get x 'fold-const-1) 't))
- (dolist (x '(= /= < > <= >= + - * /
- max min gcd lcm expt complex rem mod ash
- logtest logbitp logand logior logxor logeqv
- lognand lognor logandc1 logandc2 logorc1 logorc2
- log float float-sign))
- (setf (get x 'fold-const-2) 't))
- (defun constant-folding (insn)
- (loop
- (let ((mod nil))
- (do ((i insn (cdr i)))
- ((endp i))
- (let ((op1 (car i))
- (op2 (cadr i))
- (op3 (caddr i)))
- (cond ((and (eq (car op1) 'insn-constant)
- (numberp (cadr op1))
- (eq (car op2) 'insn-call)
- (symbolp (cadr op2))
- (get (cadr op2) 'fold-const-1)
- (= (caddr op2) 1))
- (let ((val (ignore-errors
- (multiple-value-list
- (funcall (cadr op2) (cadr op1))))))
- (when (= (length val) 1)
- (setf (cadr op1) (car val))
- (setf (cadr i) 'nil)
- (setq mod t))))
- ((and (eq (car op1) 'insn-constant)
- (numberp (cadr op1))
- (eq (car op2) 'insn-constant)
- (numberp (cadr op2))
- (eq (car op3) 'insn-call)
- (symbolp (cadr op3))
- (get (cadr op3) 'fold-const-2)
- (= (caddr op3) 2))
- (let ((val (ignore-errors
- (multiple-value-list
- (funcall (cadr op3) (cadr op1) (cadr op2))))))
- (when (= (length val) 1)
- (setf (cadr op1) (car val))
- (setf (cadr i) 'nil)
- (setf (caddr i) 'nil)
- (setq mod t)))))))
- (unless mod
- (return insn)))
- (setq insn (remove-nil-insns insn))))
- (defun optimize-insn (insn)
- (when t
- (setq insn (remove-local-lexicals insn))
- (setq insn (remove-duplicate-labels insn))
- (setq insn (optimize-jump insn))
- (setq insn (remove-unreferenced-label insn))
- (setq insn (remove-unreferenced-code insn))
- (setq insn (remove-unreferenced-label insn))
- (setq insn (optimize-set-discard-ref insn))
- (setq insn (optimize-set-discard insn))
- (setq insn (remove-ref-discard insn))
- (setq insn (constant-folding insn))
- (setq insn (remove-ref-discard insn))
- )
- insn)
- (setf (get 'cons 'optimize-form)
- #'(lambda (form)
- (if (and (= (length form) 3)
- (null (caddr form)))
- (list 'list (cadr form))
- form)))
- (setf (get 'not 'optimize-form) #'(lambda (x) `(null ,(cadr x))))
- (let ((fn #'(lambda (form)
- (if (<= (length form) 3)
- form
- (let ((ope (car form))
- (c (cadr form)))
- (dolist (x (cddr form) c)
- (setq c (list ope c x))))))))
- (dolist (x '(+ - * min max))
- (setf (get x 'optimize-form) fn)))
- (setf (get '/ 'optimize-form)
- #'(lambda (form)
- (let ((l (length form)))
- (cond ((= l 2)
- (list '/ 1 (cadr form)))
- ((<= (length form) 3)
- form)
- (t
- (let ((ope (car form))
- (c (cadr form)))
- (dolist (x (cddr form) c)
- (setq c (list ope c x)))))))))
- (let ()
- (setf (get '1+ 'optimize-form) #'(lambda (x) `(+ ,(cadr x) 1)))
- (setf (get '1- 'optimize-form) #'(lambda (x) `(- ,(cadr x) 1)))
- (setf (get 'caar 'optimize-form) #'(lambda (x) `(car (car ,(cadr x)))))
- (setf (get 'cadr 'optimize-form) #'(lambda (x) `(car (cdr ,(cadr x)))))
- (setf (get 'cdar 'optimize-form) #'(lambda (x) `(cdr (car ,(cadr x)))))
- (setf (get 'cddr 'optimize-form) #'(lambda (x) `(cdr (cdr ,(cadr x)))))
- (setf (get 'caaar 'optimize-form) #'(lambda (x) `(car (car (car ,(cadr x))))))
- (setf (get 'caadr 'optimize-form) #'(lambda (x) `(car (car (cdr ,(cadr x))))))
- (setf (get 'cadar 'optimize-form) #'(lambda (x) `(car (cdr (car ,(cadr x))))))
- (setf (get 'caddr 'optimize-form) #'(lambda (x) `(car (cdr (cdr ,(cadr x))))))
- (setf (get 'cdaar 'optimize-form) #'(lambda (x) `(cdr (car (car ,(cadr x))))))
- (setf (get 'cdadr 'optimize-form) #'(lambda (x) `(cdr (car (cdr ,(cadr x))))))
- (setf (get 'cddar 'optimize-form) #'(lambda (x) `(cdr (cdr (car ,(cadr x))))))
- (setf (get 'cdddr 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr ,(cadr x))))))
- (setf (get 'caaaar 'optimize-form) #'(lambda (x) `(car (car (car (car ,(cadr x)))))))
- (setf (get 'caaadr 'optimize-form) #'(lambda (x) `(car (car (car (cdr ,(cadr x)))))))
- (setf (get 'caadar 'optimize-form) #'(lambda (x) `(car (car (cdr (car ,(cadr x)))))))
- (setf (get 'caaddr 'optimize-form) #'(lambda (x) `(car (car (cdr (cdr ,(cadr x)))))))
- (setf (get 'cadaar 'optimize-form) #'(lambda (x) `(car (cdr (car (car ,(cadr x)))))))
- (setf (get 'cadadr 'optimize-form) #'(lambda (x) `(car (cdr (car (cdr ,(cadr x)))))))
- (setf (get 'caddar 'optimize-form) #'(lambda (x) `(car (cdr (cdr (car ,(cadr x)))))))
- (setf (get 'cadddr 'optimize-form) #'(lambda (x) `(car (cdr (cdr (cdr ,(cadr x)))))))
- (setf (get 'cdaaar 'optimize-form) #'(lambda (x) `(cdr (car (car (car ,(cadr x)))))))
- (setf (get 'cdaadr 'optimize-form) #'(lambda (x) `(cdr (car (car (cdr ,(cadr x)))))))
- (setf (get 'cdadar 'optimize-form) #'(lambda (x) `(cdr (car (cdr (car ,(cadr x)))))))
- (setf (get 'cdaddr 'optimize-form) #'(lambda (x) `(cdr (car (cdr (cdr ,(cadr x)))))))
- (setf (get 'cddaar 'optimize-form) #'(lambda (x) `(cdr (cdr (car (car ,(cadr x)))))))
- (setf (get 'cddadr 'optimize-form) #'(lambda (x) `(cdr (cdr (car (cdr ,(cadr x)))))))
- (setf (get 'cdddar 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr (car ,(cadr x)))))))
- (setf (get 'cddddr 'optimize-form) #'(lambda (x) `(cdr (cdr (cdr (cdr ,(cadr x)))))))
- (setf (get 'rest 'optimize-form) #'(lambda (x) `(cdr ,(cadr x))))
- (setf (get 'first 'optimize-form) #'(lambda (x) `(car ,(cadr x))))
- (setf (get 'second 'optimize-form) #'(lambda (x) `(car (cdr ,(cadr x)))))
- (setf (get 'third 'optimize-form) #'(lambda (x) `(car (cdr (cdr ,(cadr x))))))
- (setf (get 'fourth 'optimize-form) #'(lambda (x) `(car (cdr (cdr (cdr ,(cadr x)))))))
- (setf (get 'fifth 'optimize-form) #'(lambda (x) `(nth 4 ,(cadr x))))
- (setf (get 'sixth 'optimize-form) #'(lambda (x) `(nth 5 ,(cadr x))))
- (setf (get 'seventh 'optimize-form) #'(lambda (x) `(nth 6 ,(cadr x))))
- (setf (get 'eighth 'optimize-form) #'(lambda (x) `(nth 7 ,(cadr x))))
- (setf (get 'ninth 'optimize-form) #'(lambda (x) `(nth 8 ,(cadr x))))
- (setf (get 'tenth 'optimize-form) #'(lambda (x) `(nth 9 ,(cadr x)))))
- (let ((fn #'(lambda (x)
- (if (endp (cdr x))
- (list (car x) 1)
- x))))
- (dolist (x '(forward-char forward-line forward-virtual-line))
- (setf (get x 'optimize-form) fn)))
- (let ()
- (defconstant byte-code-constant 1)
- (defconstant byte-…
Large files files are truncated, but you can click here to view the full file