493 lines
28 KiB
Common Lisp
493 lines
28 KiB
Common Lisp
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
|
|
|
;;; Copyright (c) 1991 by Venue
|
|
|
|
(in-package "CLOS")
|
|
|
|
;;;
|
|
|
|
(defun emit-one-class-reader (class-slot-p)
|
|
(emit-reader/writer :reader 1 class-slot-p))
|
|
|
|
(defun emit-one-class-writer (class-slot-p)
|
|
(emit-reader/writer :writer 1 class-slot-p))
|
|
|
|
(defun emit-two-class-reader (class-slot-p)
|
|
(emit-reader/writer :reader 2 class-slot-p))
|
|
|
|
(defun emit-two-class-writer (class-slot-p)
|
|
(emit-reader/writer :writer 2 class-slot-p))
|
|
|
|
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
|
|
(let ((instance nil)
|
|
(arglist nil)
|
|
(closure-variables nil)
|
|
(field (wrapper-field 'number)))
|
|
; we need some field to do the fast
|
|
; obsolete check
|
|
(ecase reader/writer
|
|
(:reader (setq instance (dfun-arg-symbol 0)
|
|
arglist
|
|
(list instance)))
|
|
(:writer (setq instance (dfun-arg-symbol 1)
|
|
arglist
|
|
(list (dfun-arg-symbol 0)
|
|
instance))))
|
|
(ecase 1-or-2-class
|
|
(1 (setq closure-variables '(wrapper-0 index miss-fn)))
|
|
(2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
|
|
(generating-lap
|
|
closure-variables arglist
|
|
(with-lap-registers ((inst t)
|
|
; reg for the instance
|
|
(wrapper vector)
|
|
; reg for the wrapper
|
|
(cache-no index))
|
|
; reg for the cache no
|
|
(let ((index cache-no)
|
|
; This register is used for different
|
|
; values at different times.
|
|
(slots (and (null class-slot-p)
|
|
(allocate-register 'vector)))
|
|
(csv (and class-slot-p (allocate-register t))))
|
|
(prog1 (flatten-lap (opcode :move (operand :arg instance)
|
|
inst)
|
|
; get the instance
|
|
(opcode :std-instance-p inst 'std-instance)
|
|
; if not either std-inst
|
|
(opcode :fsc-instance-p inst 'fsc-instance)
|
|
; or fsc-instance then
|
|
(opcode :go 'trap)
|
|
; we lose
|
|
(opcode :label 'fsc-instance)
|
|
(opcode :move (operand :fsc-wrapper inst)
|
|
wrapper)
|
|
(and slots (opcode :move (operand :fsc-slots inst)
|
|
slots))
|
|
(opcode :go 'have-wrapper)
|
|
(opcode :label 'std-instance)
|
|
(opcode :move (operand :std-wrapper inst)
|
|
wrapper)
|
|
(and slots (opcode :move (operand :std-slots inst)
|
|
slots))
|
|
(opcode :label 'have-wrapper)
|
|
(opcode :move (operand :cref wrapper field)
|
|
cache-no)
|
|
(opcode :izerop cache-no 'trap)
|
|
; obsolete wrapper?
|
|
(ecase 1-or-2-class
|
|
(1 (emit-check-1-class-wrapper wrapper 'wrapper-0
|
|
'trap))
|
|
(2 (emit-check-2-class-wrapper wrapper 'wrapper-0
|
|
'wrapper-1
|
|
'trap)))
|
|
(if class-slot-p
|
|
(flatten-lap (opcode :move (operand :cvar 'index)
|
|
csv)
|
|
(ecase reader/writer
|
|
(:reader (emit-get-class-slot csv 'trap inst))
|
|
(:writer (emit-set-class-slot csv (car arglist)
|
|
inst))))
|
|
(flatten-lap (opcode :move (operand :cvar 'index)
|
|
index)
|
|
(ecase reader/writer
|
|
(:reader (emit-get-slot slots index
|
|
'trap inst))
|
|
(:writer (emit-set-slot slots index
|
|
(car arglist)
|
|
inst)))))
|
|
(opcode :label 'trap)
|
|
(emit-miss 'miss-fn))
|
|
(when slots (deallocate-register slots))
|
|
(when csv (deallocate-register csv))))))))
|
|
|
|
(defun emit-one-index-readers (class-slot-p)
|
|
(let ((arglist (list (dfun-arg-symbol 0))))
|
|
(generating-lap '(field cache mask size index miss-fn)
|
|
arglist
|
|
(with-lap-registers ((slots vector))
|
|
(emit-dlap arglist '(standard-instance)
|
|
'trap
|
|
(with-lap-registers ((index index))
|
|
(flatten-lap (opcode :move (operand :cvar 'index)
|
|
index)
|
|
(if class-slot-p
|
|
(emit-get-class-slot index 'trap slots)
|
|
(emit-get-slot slots index 'trap))))
|
|
(flatten-lap (opcode :label 'trap)
|
|
(emit-miss 'miss-fn))
|
|
nil
|
|
(and (null class-slot-p)
|
|
(list slots)))))))
|
|
|
|
(defun emit-one-index-writers (class-slot-p)
|
|
(let ((arglist (list (dfun-arg-symbol 0)
|
|
(dfun-arg-symbol 1))))
|
|
(generating-lap '(field cache mask size index miss-fn)
|
|
arglist
|
|
(with-lap-registers ((slots vector))
|
|
(emit-dlap arglist '(t standard-instance)
|
|
'trap
|
|
(with-lap-registers ((index index))
|
|
(flatten-lap (opcode :move (operand :cvar 'index)
|
|
index)
|
|
(if class-slot-p
|
|
(emit-set-class-slot index (dfun-arg-symbol 0)
|
|
slots)
|
|
(emit-set-slot slots index (dfun-arg-symbol 0)))))
|
|
(flatten-lap (opcode :label 'trap)
|
|
(emit-miss 'miss-fn))
|
|
nil
|
|
(and (null class-slot-p)
|
|
(list nil slots)))))))
|
|
|
|
(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
|
|
(generating-lap '(field cache mask size miss-fn)
|
|
arglist
|
|
(with-lap-registers ((slots vector)
|
|
(index index))
|
|
(emit-dlap arglist '(standard-instance)
|
|
'trap
|
|
(emit-get-slot slots index 'trap)
|
|
(flatten-lap (opcode :label 'trap)
|
|
(emit-miss 'miss-fn))
|
|
index
|
|
(list slots))))))
|
|
|
|
(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
|
|
(dfun-arg-symbol 1))))
|
|
(generating-lap '(field cache mask size miss-fn)
|
|
arglist
|
|
(with-lap-registers ((slots vector)
|
|
(index index))
|
|
(flatten-lap (emit-dlap arglist '(t standard-instance)
|
|
'trap
|
|
(emit-set-slot slots index
|
|
(dfun-arg-symbol 0))
|
|
(flatten-lap (opcode :label
|
|
'trap)
|
|
(emit-miss 'miss-fn))
|
|
index
|
|
(list nil slots)))))))
|
|
|
|
(defun emit-checking (metatypes applyp)
|
|
(let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
|
|
(generating-lap '(field cache mask size function miss-fn)
|
|
dlap-lambda-list
|
|
(emit-dlap (remove '&rest dlap-lambda-list)
|
|
metatypes
|
|
'trap
|
|
(with-lap-registers (#'t)
|
|
(flatten-lap (opcode :move (operand :cvar 'function)
|
|
function)
|
|
(opcode :jmp function)))
|
|
(with-lap-registers ((miss-function t))
|
|
(flatten-lap (opcode :label 'trap)
|
|
(opcode :move (operand :cvar 'miss-fn)
|
|
miss-function)
|
|
(opcode :jmp miss-function)))
|
|
nil))))
|
|
|
|
(defun emit-caching (metatypes applyp)
|
|
(let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
|
|
(generating-lap '(field cache mask size miss-fn)
|
|
dlap-lambda-list
|
|
(with-lap-registers (#'t)
|
|
(emit-dlap (remove '&rest dlap-lambda-list)
|
|
metatypes
|
|
'trap
|
|
(flatten-lap (opcode :jmp function))
|
|
(with-lap-registers ((miss-function t))
|
|
(flatten-lap (opcode :label 'trap)
|
|
(opcode :move (operand :cvar 'miss-fn)
|
|
miss-function)
|
|
(opcode :jmp miss-function)))
|
|
function)))))
|
|
|
|
(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
|
|
(with-lap-registers ((cwrapper vector))
|
|
(flatten-lap (opcode :move (operand :cvar cwrapper-0)
|
|
cwrapper)
|
|
(opcode :neq wrapper cwrapper miss-label))))
|
|
|
|
; wrappers not eq, trap
|
|
|
|
|
|
(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
|
|
(with-lap-registers ((cwrapper vector))
|
|
(flatten-lap (opcode :move (operand :cvar cwrapper-0)
|
|
cwrapper)
|
|
; This is an OR. Isn't
|
|
(opcode :eq wrapper cwrapper 'hit-internal)
|
|
; assembly code fun
|
|
(opcode :move (operand :cvar cwrapper-1)
|
|
cwrapper)
|
|
;
|
|
(opcode :neq wrapper cwrapper miss-label)
|
|
;
|
|
(opcode :label 'hit-internal))))
|
|
|
|
(defun emit-get-slot (slots index trap-label &optional temp)
|
|
(let ((slot-unbound (operand :constant *slot-unbound*)))
|
|
(with-lap-registers ((val t :reuse temp))
|
|
(flatten-lap (opcode :move (operand :iref slots index)
|
|
val)
|
|
; get slot value
|
|
(opcode :eq val slot-unbound trap-label)
|
|
; is the slot unbound?
|
|
(opcode :return val)))))
|
|
|
|
; return the slot value
|
|
|
|
|
|
(defun emit-set-slot (slots index new-value-arg &optional temp)
|
|
(with-lap-registers ((new-val t :reuse temp))
|
|
(flatten-lap (opcode :move (operand :arg new-value-arg)
|
|
new-val)
|
|
; get new value into a reg
|
|
(opcode :move new-val (operand :iref slots index))
|
|
; set slot value
|
|
(opcode :return new-val))))
|
|
|
|
(defun emit-get-class-slot (index trap-label &optional temp)
|
|
(let ((slot-unbound (operand :constant *slot-unbound*)))
|
|
(with-lap-registers ((val t :reuse temp))
|
|
(flatten-lap (opcode :move (operand :cdr index)
|
|
val)
|
|
(opcode :eq val slot-unbound trap-label)
|
|
(opcode :return val)))))
|
|
|
|
(defun emit-set-class-slot (index new-value-arg &optional temp)
|
|
(with-lap-registers ((new-val t :reuse temp))
|
|
(flatten-lap (opcode :move (operand :arg new-value-arg)
|
|
new-val)
|
|
(opcode :move new-val (operand :cdr index))
|
|
(opcode :return new-val))))
|
|
|
|
(defun emit-miss (miss-fn)
|
|
(with-lap-registers ((miss-fn-reg t))
|
|
(flatten-lap (opcode :move (operand :cvar miss-fn)
|
|
miss-fn-reg)
|
|
; get the miss function
|
|
(opcode :jmp miss-fn-reg))))
|
|
|
|
; and call it
|
|
|
|
|
|
(defun dlap-wrappers (metatypes)
|
|
(mapcar #'(lambda (x)
|
|
(and (neq x 't)
|
|
(allocate-register 'vector)))
|
|
metatypes))
|
|
|
|
(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
|
|
(gathering1 (collecting)
|
|
(iterate ((mt (list-elements metatypes))
|
|
(arg (list-elements args))
|
|
(wrapper (list-elements wrappers))
|
|
(i (interval :from 0)))
|
|
(when wrapper
|
|
(gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
|
|
))
|
|
|
|
(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
|
|
(let* ((wrappers (dlap-wrappers metatypes))
|
|
(nwrappers (remove nil wrappers))
|
|
(wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
|
|
(prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
|
|
(mapc #'deallocate-register nwrappers))))
|
|
|
|
(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
|
|
(cond ((cdr wrapper-regs)
|
|
(emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
|
|
((null value-reg)
|
|
(emit-1-nil-dlap (car wrapper-regs)
|
|
(car wrapper-moves)
|
|
hit miss miss-label))
|
|
(t (emit-1-t-dlap (car wrapper-regs)
|
|
(car wrapper-moves)
|
|
hit miss miss-label value-reg))))
|
|
|
|
(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
|
|
(with-lap-registers ((location index)
|
|
(primary index)
|
|
(cache vector))
|
|
(flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
|
|
cache)
|
|
(with-lap-registers ((wrapper-cache-no index))
|
|
(flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper
|
|
primary wrapper-cache-no)
|
|
(opcode :move primary location)
|
|
(emit-check-1-wrapper-in-cache cache location wrapper hit)
|
|
; inline hit code
|
|
(opcode :izerop wrapper-cache-no miss-label)))
|
|
(with-lap-registers ((size index))
|
|
(flatten-lap (opcode :move (operand :cvar 'size)
|
|
size)
|
|
(opcode :label 'loop)
|
|
(opcode :move (operand :i1+ location)
|
|
location)
|
|
(opcode :fix= location primary miss-label)
|
|
(opcode :fix= location size 'set-location-to-min)
|
|
(opcode :label 'continue)
|
|
(emit-check-1-wrapper-in-cache cache location wrapper hit)
|
|
(opcode :go 'loop)
|
|
(opcode :label 'set-location-to-min)
|
|
(opcode :izerop primary miss-label)
|
|
(opcode :move (operand :constant (index-value->index 0))
|
|
location)
|
|
(opcode :go 'continue)))
|
|
miss)))
|
|
|
|
|
|
;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0).
|
|
;;; This should probably be abstracted.
|
|
|
|
|
|
(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
|
|
(with-lap-registers ((location index)
|
|
(primary index)
|
|
(cache vector)
|
|
(initial-lock-count t))
|
|
(flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
|
|
cache)
|
|
(with-lap-registers ((wrapper-cache-no index))
|
|
(flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper
|
|
primary wrapper-cache-no)
|
|
(opcode :move primary location)
|
|
(opcode :move (operand :cref cache 0)
|
|
initial-lock-count)
|
|
; get lock-count
|
|
(emit-check-cache-entry cache location wrapper 'hit-internal)
|
|
(opcode :izerop wrapper-cache-no miss-label)))
|
|
; check for obsolescence
|
|
(with-lap-registers ((size index))
|
|
(flatten-lap (opcode :move (operand :cvar 'size)
|
|
size)
|
|
(opcode :label 'loop)
|
|
(opcode :move (operand :i1+ location)
|
|
location)
|
|
(opcode :move (operand :i1+ location)
|
|
location)
|
|
(opcode :label 'continue)
|
|
(opcode :fix= location primary miss-label)
|
|
(opcode :fix= location size 'set-location-to-min)
|
|
(emit-check-cache-entry cache location wrapper 'hit-internal)
|
|
(opcode :go 'loop)
|
|
(opcode :label 'set-location-to-min)
|
|
(opcode :izerop primary miss-label)
|
|
(opcode :move (operand :constant (index-value->index 2))
|
|
location)
|
|
(opcode :go 'continue)))
|
|
(opcode :label 'hit-internal)
|
|
(opcode :move (operand :i1+ location)
|
|
location)
|
|
; position for getting value
|
|
(opcode :move (emit-cache-ref cache location)
|
|
value)
|
|
(emit-lock-count-test initial-lock-count cache 'hit)
|
|
miss
|
|
(opcode :label 'hit)
|
|
hit)))
|
|
|
|
(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
|
|
(let ((cache-line-size (compute-line-size (+ (length wrappers)
|
|
(if value
|
|
1
|
|
0)))))
|
|
(with-lap-registers ((location index)
|
|
(primary index)
|
|
(cache vector)
|
|
(initial-lock-count t)
|
|
(next-location index)
|
|
(line-size index))
|
|
; Line size holds a constant that can
|
|
; be folded in if there was a way to
|
|
; add a constant to an index register
|
|
(flatten-lap (apply #'flatten-lap wrapper-moves)
|
|
(opcode :move (operand :constant cache-line-size)
|
|
line-size)
|
|
(opcode :move (operand :cvar 'cache)
|
|
cache)
|
|
(emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
|
|
(opcode :move primary location)
|
|
(opcode :move location next-location)
|
|
(opcode :move (operand :cref cache 0)
|
|
initial-lock-count)
|
|
; get the lock-count
|
|
(with-lap-registers ((size index))
|
|
(flatten-lap (opcode :move (operand :cvar 'size)
|
|
size)
|
|
(opcode :label 'continue)
|
|
(opcode :move (operand :i+ location line-size)
|
|
next-location)
|
|
(emit-check-cache-line cache location wrappers 'hit)
|
|
(emit-adjust-location location next-location primary size
|
|
'continue miss-label)
|
|
(opcode :label 'hit)
|
|
(and value (opcode :move (emit-cache-ref cache location)
|
|
value))
|
|
(emit-lock-count-test initial-lock-count cache 'hit-internal)
|
|
miss
|
|
(opcode :label 'hit-internal)
|
|
hit))))))
|
|
|
|
|
|
;;; Cache related lap code
|
|
|
|
|
|
(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
|
|
(let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
|
|
(with-lap-registers ((cwrapper vector))
|
|
(flatten-lap (opcode :move (emit-cache-ref cache location)
|
|
cwrapper)
|
|
(opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
|
|
hit-code
|
|
(opcode :label exit-emit-check-1-wrapper-in-cache)))))
|
|
|
|
(defun emit-check-cache-entry (cache location wrapper hit-label)
|
|
(with-lap-registers ((cwrapper vector))
|
|
(flatten-lap (opcode :move (emit-cache-ref cache location)
|
|
cwrapper)
|
|
(opcode :eq cwrapper wrapper hit-label))))
|
|
|
|
(defun emit-check-cache-line (cache location wrappers hit-label)
|
|
(let ((checks (flatten-lap (gathering1 (flattening-lap)
|
|
(iterate ((wrapper (list-elements wrappers)))
|
|
(with-lap-registers ((cwrapper vector))
|
|
(gather1 (flatten-lap (opcode :move
|
|
(emit-cache-ref
|
|
cache location)
|
|
cwrapper)
|
|
(opcode :neq cwrapper wrapper
|
|
|
|
'
|
|
exit-emit-check-cache-line
|
|
)
|
|
(opcode :move (operand :i1+
|
|
location)
|
|
location)))))))))
|
|
(flatten-lap checks (opcode :go hit-label)
|
|
(opcode :label 'exit-emit-check-cache-line))))
|
|
|
|
(defun emit-lock-count-test (initial-lock-count cache hit-label)
|
|
|
|
;; jumps to hit-label if cache-lock-count consistent, otherwise, continues
|
|
(with-lap-registers ((new-lock-count t))
|
|
(flatten-lap (opcode :move (operand :cref cache 0)
|
|
new-lock-count)
|
|
; get new cache-lock-count
|
|
(opcode :fix= new-lock-count initial-lock-count hit-label))))
|
|
|
|
(defun emit-adjust-location (location next-location primary size cont-label miss-label)
|
|
(flatten-lap (opcode :move next-location location)
|
|
(opcode :fix= location size 'at-end-of-cache)
|
|
(opcode :fix= location primary miss-label)
|
|
(opcode :go cont-label)
|
|
(opcode :label 'at-end-of-cache)
|
|
(opcode :fix= primary (operand :constant (index-value->index 1))
|
|
miss-label)
|
|
(opcode :move (operand :constant (index-value->index 1))
|
|
location)
|
|
(opcode :go cont-label)))
|