310 lines
12 KiB
Common Lisp
310 lines
12 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
|
|
;;;. Copyright (c) 1991 by Venue
|
|
|
|
(in-package "CLOS")
|
|
|
|
|
|
;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
|
|
;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code.
|
|
;;; Note that this implementation is actually going to get a lot of use. Some implementations (KCL)
|
|
;;; won't implement a native LAP assembler at all. Other implementations may not implement native
|
|
;;; LAP assemblers for all of their ports. All of this implies that this portable LAP assembler
|
|
;;; needs to generate the best code it possibly can.
|
|
|
|
|
|
(defmacro
|
|
lap-case
|
|
(operand &body cases)
|
|
(once-only
|
|
(operand)
|
|
`(ecase (car ,operand)
|
|
,@(mapcar #'(lambda (case)
|
|
`(,(car case)
|
|
(apply #'(lambda ,(cadr case)
|
|
,@(cddr case))
|
|
(cdr ,operand))))
|
|
cases))))
|
|
|
|
(defvar *lap-args*)
|
|
|
|
(defvar *lap-rest-p*)
|
|
|
|
(defvar *lap-i-regs*)
|
|
|
|
(defvar *lap-v-regs*)
|
|
|
|
(defvar *lap-t-regs*)
|
|
|
|
(defvar *lap-optimize-declaration* '((speed 3)
|
|
(safety 0)
|
|
(compilation-speed 0)))
|
|
|
|
(eval-when (load eval)
|
|
(setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs
|
|
vector-regs t-regs lap-code)
|
|
(compile-lambda (make-lap-closure-generator-lambda
|
|
closure-var-names arg-names
|
|
index-regs vector-regs t-regs
|
|
lap-code)))
|
|
*precompile-lap-closure-generator*
|
|
#'(lambda (cvars args i-regs v-regs t-regs lap)
|
|
`#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
|
|
*lap-in-lisp*
|
|
#'(lambda (cvars args iregs vregs tregs lap)
|
|
(declare (ignore cvars args))
|
|
(make-lap-prog iregs vregs tregs (flatten-lap lap
|
|
; (opcode :label 'exit-lap-in-lisp)
|
|
)))))
|
|
|
|
(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
|
|
(let* ((rest (memq '&rest args))
|
|
(ldiff (and rest (ldiff args rest))))
|
|
(when rest
|
|
(setq args (append ldiff '(&rest .lap-rest-arg.))))
|
|
(let* ((*lap-args* (if rest
|
|
ldiff
|
|
args))
|
|
(*lap-rest-p* (not (null rest))))
|
|
`(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
|
|
,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
|
|
|
|
(defun make-lap-prog (i-regs v-regs t-regs lap)
|
|
(let* ((*lap-args* 'lap-in-lisp)
|
|
(*lap-rest-p* 'lap-in-lisp))
|
|
(make-lap-prog-internal i-regs v-regs t-regs lap)))
|
|
|
|
(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
|
|
(let* ((*lap-i-regs* i-regs)
|
|
(*lap-v-regs* v-regs)
|
|
(*lap-t-regs* t-regs)
|
|
(code (mapcar #'lap-opcode lap)))
|
|
`(prog ,(mapcar #'(lambda (reg)
|
|
`(,(lap-reg reg)
|
|
,(lap-reg-initial-value-form reg)))
|
|
(append i-regs v-regs t-regs))
|
|
(declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
|
|
(type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
|
|
(optimize . ,*lap-optimize-declaration*))
|
|
,.code)))
|
|
|
|
(defconstant *empty-vector* '#())
|
|
|
|
(defun lap-reg-initial-value-form (reg)
|
|
(cond ((member reg *lap-i-regs*)
|
|
0)
|
|
((member reg *lap-v-regs*)
|
|
'*empty-vector*)
|
|
((member reg *lap-t-regs*)
|
|
nil)
|
|
(t (error "What kind of register is ~S?" reg))))
|
|
|
|
(defun lap-opcode (opcode)
|
|
(lap-case opcode (:move (from to)
|
|
`(setf ,(lap-operand to)
|
|
,(lap-operand from)))
|
|
((:eq :neq :fix=)
|
|
(arg1 arg2 label)
|
|
`(when ,(lap-operands (ecase (car opcode)
|
|
(:eq 'eq)
|
|
(:neq 'neq)
|
|
(:fix= 'runtime\ fix=))
|
|
arg1 arg2)
|
|
(go ,label)))
|
|
((:izerop)
|
|
(arg label)
|
|
`(when ,(lap-operands 'runtime\ izerop arg)
|
|
(go ,label)))
|
|
(:std-instance-p (from label)
|
|
`(when ,(lap-operands 'runtime\ std-instance-p from)
|
|
(go ,label)))
|
|
(:fsc-instance-p (from label)
|
|
`(when ,(lap-operands 'runtime\ fsc-instance-p from)
|
|
(go ,label)))
|
|
(:built-in-instance-p (from label)
|
|
(declare (ignore from))
|
|
`(when ,t
|
|
(go ,label)))
|
|
; ***
|
|
(:structure-instance-p (from label)
|
|
`(when ,(lap-operands 'runtime\ ??? from)
|
|
(go ,label)))
|
|
; ***
|
|
(:jmp (fn)
|
|
(if (eq *lap-args* 'lap-in-lisp)
|
|
(error "Can't do a :JMP in LAP-IN-LISP.")
|
|
`(return ,(if *lap-rest-p*
|
|
`(runtime\ apply ,(lap-operand fn)
|
|
,@*lap-args* .lap-rest-arg.)
|
|
`(runtime\ funcall ,(lap-operand fn)
|
|
,@*lap-args*)))))
|
|
(:return (value)
|
|
`(return ,(lap-operand value)))
|
|
(:label (label)
|
|
label)
|
|
(:go (label)
|
|
`(go ,label))
|
|
(:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
|
|
(:break nil `(break))
|
|
(:beep nil)
|
|
(:print (val)
|
|
(lap-operands 'print val))))
|
|
|
|
(defun lap-operand (operand)
|
|
(lap-case operand (:reg (n)
|
|
(lap-reg n))
|
|
(:cdr (reg)
|
|
(lap-operands 'cdr reg))
|
|
((:cvar :arg)
|
|
(name)
|
|
name)
|
|
(:constant (c)
|
|
`',c)
|
|
((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
|
|
(x)
|
|
(lap-operands (ecase (car operand)
|
|
(:std-wrapper 'runtime\ std-wrapper)
|
|
(:fsc-wrapper 'runtime\ fsc-wrapper)
|
|
(:built-in-wrapper 'runtime\ built-in-wrapper)
|
|
(:structure-wrapper 'runtime\ structure-wrapper)
|
|
(:std-slots 'runtime\ std-slots)
|
|
(:fsc-slots 'runtime\ fsc-slots))
|
|
x))
|
|
(:i1+ (index)
|
|
(lap-operands 'runtime\ i1+ index))
|
|
(:i+ (index1 index2)
|
|
(lap-operands 'runtime\ i+ index1 index2))
|
|
(:i- (index1 index2)
|
|
(lap-operands 'runtime\ i- index1 index2))
|
|
(:ilogand (index1 index2)
|
|
(lap-operands 'runtime\ ilogand index1 index2))
|
|
(:ilogxor (index1 index2)
|
|
(lap-operands 'runtime\ ilogxor index1 index2))
|
|
(:iref (vector index)
|
|
(lap-operands 'runtime\ iref vector index))
|
|
(:iset (vector index value)
|
|
(lap-operands 'runtime\ iset vector index value))
|
|
(:cref (vector i)
|
|
`(runtime\ svref ,(lap-operand vector)
|
|
,i))
|
|
(:lisp-variable (symbol)
|
|
symbol)
|
|
(:lisp (form)
|
|
form)))
|
|
|
|
(defun lap-operands (fn &rest regs)
|
|
(cons fn (mapcar #'lap-operand regs)))
|
|
|
|
(defun lap-reg (n)
|
|
(intern (format nil "REG~D" n)
|
|
*the-clos-package*))
|
|
|
|
|
|
;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
|
|
;;; completely re-implement the LAP code generator, it may still be provident to consider
|
|
;;; reimplementing one or more of these to get the compiler to produce better code. That is why
|
|
;;; they are split out.
|
|
|
|
|
|
(proclaim '(declaration clos-fast-call))
|
|
|
|
(defmacro runtime\ funcall (fn &rest args)
|
|
`(funcall ,fn ,.args))
|
|
|
|
(defmacro runtime\ apply (fn &rest args)
|
|
`(apply ,fn ,.args))
|
|
|
|
(defmacro runtime\ std-wrapper (x)
|
|
`(std-instance-wrapper ,x))
|
|
|
|
(defmacro runtime\ fsc-wrapper (x)
|
|
`(fsc-instance-wrapper ,x))
|
|
|
|
(defmacro runtime\ built-in-wrapper (x)
|
|
`(built-in-wrapper-of ,x))
|
|
|
|
(defmacro runtime\ structure-wrapper (x)
|
|
`(??? ,x))
|
|
|
|
(defmacro runtime\ std-slots (x)
|
|
`(std-instance-slots (the std-instance ,x)))
|
|
|
|
(defmacro runtime\ fsc-slots (x)
|
|
`(fsc-instance-slots ,x))
|
|
|
|
(defmacro runtime\ std-instance-p (x)
|
|
`(std-instance-p ,x))
|
|
|
|
(defmacro runtime\ fsc-instance-p (x)
|
|
`(fsc-instance-p ,x))
|
|
|
|
(defmacro runtime\ izerop (x)
|
|
`(zerop (the fixnum ,x)))
|
|
|
|
(defmacro runtime\ fix= (x y)
|
|
`(= (the fixnum ,x)
|
|
(the fixnum ,y)))
|
|
|
|
|
|
;;; These are the implementations of the index operands. The portable assembler generates Lisp code
|
|
;;; that uses these macros. Even though the variables holding the arguments and results have type
|
|
;;; declarations on them, we put type declarations in here. Some compilers are so stupid...
|
|
|
|
|
|
(defmacro runtime\ iref (vector index)
|
|
`(svref (the simple-vector ,vector)
|
|
(the fixnum ,index)))
|
|
|
|
(defmacro runtime\ iset (vector index value)
|
|
`(setf (svref (the simple-vector ,vector)
|
|
(the fixnum ,index))
|
|
,value))
|
|
|
|
(defmacro runtime\ svref (vector fixnum)
|
|
`(svref (the simple-vector ,vector)
|
|
(the fixnum ,fixnum)))
|
|
|
|
(defmacro runtime\ i+ (index1 index2)
|
|
`(the fixnum (+ (the fixnum ,index1)
|
|
(the fixnum ,index2))))
|
|
|
|
(defmacro runtime\ i- (index1 index2)
|
|
`(the fixnum (- (the fixnum ,index1)
|
|
(the fixnum ,index2))))
|
|
|
|
(defmacro runtime\ i1+ (index)
|
|
`(the fixnum (1+ (the fixnum ,index))))
|
|
|
|
(defmacro runtime\ ilogand (index1 index2)
|
|
`(the fixnum (logand (the fixnum ,index1)
|
|
(the fixnum ,index2))))
|
|
|
|
(defmacro runtime\ ilogxor (index1 index2)
|
|
`(the fixnum (logxor (the fixnum ,index1)
|
|
(the fixnum ,index2))))
|
|
|
|
|
|
;;; In the portable implementation, indexes are just fixnums.
|
|
|
|
|
|
(defconstant index-value-limit most-positive-fixnum)
|
|
|
|
(defun index-value->index (index-value)
|
|
index-value)
|
|
|
|
(defun index->index-value (index)
|
|
index)
|
|
|
|
(defun make-index-mask (cache-size line-size)
|
|
(let ((cache-size-in-bits (floor (log cache-size 2)))
|
|
(line-size-in-bits (floor (log line-size 2)))
|
|
(mask 0))
|
|
(dotimes (i cache-size-in-bits)
|
|
(setq mask (dpb 1 (byte 1 i)
|
|
mask)))
|
|
(dotimes (i line-size-in-bits)
|
|
(setq mask (dpb 0 (byte 1 i)
|
|
mask)))
|
|
mask))
|