r1/oo.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 223 646d45b098aa
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.

(require 'srfi-1)

;---------------------------------------------------------------------------

(define-record-type slot
  (make-slot* name index roles delegating? kind)
  slot?
  (name slot-name)			;; symbol
  (index slot-index set-slot-index!)	;; #f, or integer offset into object-slots vector
  (roles slot-roles set-slot-roles!)	;; list of roles
  (delegating? slot-delegating?)	;; boolean
  (kind slot-kind))			;; 'method, 'immutable, or 'mutable

(define-record-type object
  (make-object* layout slots)
  object?
  (layout object-layout set-object-layout!)
  (slots object-slots set-object-slots!))

(define-record-type role
  (make-role* positions requirements method)
  role?
  (positions role-positions set-role-positions!)
  (requirements role-requirements)
  (method role-method set-role-method!))

(define-record-type layout
  (make-layout** hash map)
  layout?
  (hash layout-hash)
  (map layout-map))

(define layout-hash-factory
  (let ((counter 0))
    (lambda ()
      (let ((v counter))
	(set! counter (bitwise-and (+ counter 1) #xFFFFFF)) ;; some arbitrary wraparound
	v))))

(define (make-layout*)
  (make-layout** (layout-hash-factory)
		 (make-hash-table eq?)))

(define (layout-ref layout slot-name def)
  (hash-table-ref (layout-map layout) slot-name def))

(define (layout-set! layout slot-name value)
  (hash-table-set! (layout-map layout) slot-name value))

(define (layout-for-each layout fn)
  (hash-table-for-each fn (layout-map layout)))

(define (layout-remove! layout slot-name)
  (hash-table-remove! (layout-map layout) slot-name))

;---------------------------------------------------------------------------

(define *literal-objects* 'uninitialised-literal-objects)

(define (flush-literal-objects-table!)
  (set! *literal-objects* (make-hash-table eq?)))

(define (object-for-literal! x)
  (or (hash-table-ref *literal-objects* x #f)
      (let* ((ob (make-object* (make-layout*) (vector)))
	     (t (traits-for-primitive x)))
	(add-slot! ob 'traits (traits-for-primitive x) #t 'immutable)
	(hash-table-set! *literal-objects* x ob)
	ob)))

(define (install-object-for-literal! x ob)
  (unless (hash-table-ref *literal-objects* x #f)
    (hash-table-set! *literal-objects* x ob)))

(define (for-each-literal-object fn)
  (hash-table-for-each fn *literal-objects*))

(define (ensure-object! x)
  (if (object? x)
      x
      (object-for-literal! x)))

(define (object-or-false x)
  (if (object? x)
      x
      (hash-table-ref *literal-objects* x #f)))

(define-syntax ensure-object-var/create!
  (syntax-rules ()
    ((_ var)
     (begin
       (unless (object? var)
	 (set! var (object-for-literal! var)))))))

(define-syntax ensure-object-var/traits
  (syntax-rules ()
    ((_ var)
     (begin
       (unless (object? var)
	 (set! var (or (hash-table-ref *literal-objects* var #f)
		       (traits-for-primitive var))))))))

;---------------------------------------------------------------------------

(define (clone-object o)
  (let* ((o-slots (object-slots o))
	 (new-slots (make-vector (vector-length o-slots))))
    (vector-copy! o-slots new-slots)
    (make-object* (object-layout o)
		  new-slots)))

(define (clone-layout layout)
  (let ((new-layout (make-layout*)))
    (layout-for-each layout
		     (lambda (slot-name slot)
		       (layout-set! new-layout slot-name slot)))
    new-layout))

(define (clone-slot slot)
  (make-slot* (slot-name slot)
	      (slot-index slot)
	      (slot-roles slot)
	      (slot-delegating? slot)
	      (slot-kind slot)))

(define (merge-slot-kinds current new)
  (if (kind-is-non-slot? current)
      new
      current))

(define (kind-is-slot? kind)
  (not (eq? kind 'method)))

(define (kind-is-non-slot? kind)
  (eq? kind 'method))

(define (add-slot! o name value delegating? kind . should-add-accessors)
  (ensure-object-var/create! o)
  (debug 1 "Add-slot: "o" "name" "value" "delegating?" "kind" "should-add-accessors)
  (let* ((layout (clone-layout (object-layout o)))
	 (old-slot (layout-ref layout name #f))
	 (slot (if old-slot
		   (make-slot* name
			       (slot-index old-slot)
			       (slot-roles old-slot)
			       (or (slot-delegating? old-slot) delegating?)
			       (merge-slot-kinds (slot-kind old-slot) kind))
		   (make-slot* name
			       #f
			       '()
			       delegating?
			       kind))))
    (layout-set! layout name slot)
    (set-object-layout! o layout)
    (let ((index (slot-index slot)))
      (if (not index)
	  (let* ((new-index (vector-length (object-slots o)))
		 (new-slots (make-vector (+ new-index 1))))
	    (vector-copy! (object-slots o) new-slots)
	    (vector-set! new-slots new-index value)
	    (set-slot-index! slot new-index)
	    (set-object-slots! o new-slots))
	  (vector-set! (object-slots o) index value)))
    (when (and (or (null? should-add-accessors) (car should-add-accessors))
	       (kind-is-slot? kind)
	       (or (not old-slot)
		   (kind-is-non-slot? (slot-kind old-slot))))
      (add-accessors! o name (eq? kind 'immutable)))
    o))

(define (mutator-name-for name)
  (string->symbol (string-append (symbol->string name) ":")))

(define (add-accessors! o name immutable?)
  (debug 2 "Adding getter for "name" on "o)
  (add-roles!* name #f (make-getter-method-for name) (list o))
  (if (not immutable?)
      (let ((mutator-name (mutator-name-for name)))
	(debug 2 "Adding setter for "name" ("mutator-name") on "o)
	(add-roles!* mutator-name #f (make-setter-method-for name mutator-name)
		     ;; You'd think we'd need a two-element list here,
		     ;; but we don't. This is because of the sparse
		     ;; encoding of roles. Essentially, setter methods
		     ;; only have a constraint on their first
		     ;; argument, so we don't have to bother about the
		     ;; second argument at all.
		     (list o))))
  o)

(define (collect-bitset filter specialisers)
  (fold-left/index (lambda (index specialiser acc)
		     (if (filter specialiser)
			 (set-bit acc index)
			 acc))
		   *empty-bitset* specialisers))

(define (not-no-role? specialiser)
  (not (eq? specialiser *no-role*)))

(define (add-roles!* name clone-existing-slot? method specialisers)
  (let ((requirements (collect-bitset not-no-role? specialisers)))
    (for-each/index
     (lambda (index specialiser)
       (when (not-no-role? specialiser)
	 (add-role! specialiser name clone-existing-slot? index requirements method)))
     specialisers)))

(define (add-role! o name clone-existing-slot? index requirements method)
  (ensure-object-var/create! o)
  (let* ((layout (clone-layout (object-layout o)))
	 (old-slot (layout-ref layout name #f))
	 (slot (if old-slot
		   (if clone-existing-slot? (clone-slot old-slot) old-slot)
		   (make-slot* name
			       #f
			       '()
			       #f
			       'method))))
    (layout-set! layout name slot)
    (set-object-layout! o layout)
    (let update-roles ((roles (slot-roles slot)))
      (if (null? roles)
	  (set-slot-roles! slot
			   (cons (make-role* (set-bit *empty-bitset* index) requirements method)
				 (slot-roles slot)))
	  (let ((role (car roles)))
	    (if (eq? (role-method role) method)
		(set-role-positions! role (set-bit (role-positions role) index))
		(update-roles (cdr roles))))))
    (invalidate-method-cache!)
    o))

(define remove-slot!
  (let ()
    (define (splice-out-slot-value! o removed-index)
      (let* ((old-slots (object-slots o))
	     (old-slots-length (vector-length old-slots))
	     (new-slots (make-vector (- old-slots-length 1))))
	(do ((i 0 (+ i 1)))
	    ((= i removed-index))
	  (vector-set! new-slots i (vector-ref old-slots i)))
	(do ((i (+ removed-index 1) (+ i 1)))
	    ((= i old-slots-length))
	  (vector-set! new-slots (- i 1) (vector-ref old-slots i)))
	(set-object-slots! o new-slots)
	(vector-ref old-slots removed-index)))

    (define (fixup-other-slot-indices! layout removed-index)
      (layout-for-each layout
		       (lambda (slot-name slot)
			 (if (> (slot-index slot) removed-index)
			     (set-slot-index! slot (- (slot-index slot) 1))))))

    (define (remove-mutator-role! layout name)
      (let* ((mutator-name (mutator-name-for name))
	     (mutator-slot (layout-ref layout mutator-name #f)))
	(if mutator-slot
	    (let* ((new-slot (clone-slot mutator-slot)))
	      (set-slot-roles! new-slot
			       ;; Ought this to just remove *one*? Can there ever be more than one?
			       (filter (lambda (role)
					 (not (eq? (get-slot (role-method role) 'accessor) name)))
				       (slot-roles new-slot)))
	      (if (null? (slot-roles new-slot))
		  (layout-remove! layout mutator-name)
		  (layout-set! layout mutator-name new-slot))))))

    (lambda (o name)
      (and-let* ((o (object-or-false o)))
	(let* ((layout (clone-layout (object-layout o)))
	       (removed-slot (layout-ref layout name #f))
	       (removed-index (slot-index removed-slot)))
	  (set-object-layout! o layout)
	  (let ((old-value (splice-out-slot-value! o removed-index)))
	    (fixup-other-slot-indices! layout removed-index)
	    (layout-remove! layout name)
	    (if (eq? (slot-kind removed-slot) 'mutable)
		(remove-mutator-role! layout name))
	    (invalidate-method-cache!)
	    old-value))))))

(define replace-method!
  (let ()
    (define (find-specific-method name specialisers)
      (let ((requirements (collect-bitset not-no-role? specialisers)))
	(let loop ((found-methods #f)
		   (specialisers specialisers)
		   (index 0))
	  (cond
	   ((null? found-methods) #f)
	   ((null? specialisers)
	    (cond
	     ((not found-methods) #f)
	     ((pair? (cdr found-methods))
	      (error 'too-many-matches-candidates (list name specialisers)))
	     (else (car found-methods))))
	   (else
	    (and-let* ((specialiser (object-or-false (car specialisers))))
	      (if (not-no-role? specialiser)
		  (and-let* ((slot (layout-ref (object-layout specialiser) name #f)))
		    (let ((new-methods (map role-method
					    (filter (lambda (role)
						      (and (bit-set? (role-positions role)
								     index)
							   (bitset=? (role-requirements role)
								     requirements)))
						    (slot-roles slot)))))
		      (loop (if found-methods
				(lset-intersection eq? found-methods new-methods)
				new-methods)
			    (cdr specialisers)
			    (+ index 1))))
		  (loop found-methods (cdr specialisers) (+ index 1)))))))))

    (lambda (name specialisers new-method)
      (and-let* ((found-method (find-specific-method name specialisers)))
	(for-each (lambda (specialiser)
		    (let ((specialiser (object-or-false specialiser)))
		      (when (not-no-role? specialiser)
			(let* ((slot (clone-slot (layout-ref (object-layout specialiser)
							     name #f))))
			  (layout-set! (object-layout specialiser) slot)
			  (for-each (lambda (role)
				      (if (eq? (role-method role) found-method)
					  (set-role-method! role new-method)))
				    (slot-roles slot))))))
		  specialisers)
	found-method))))

(define (has-slot? object-or-primitive name)
  (let ((o (object-or-false object-or-primitive)))
    (if o
	(layout-ref (object-layout o) name #f)
	(eq? name 'traits))))

(define (get-slot object-or-primitive name)
  (let ((o (object-or-false object-or-primitive)))
    (if o
	(and-let* ((slot (layout-ref (object-layout o) name #f))
		   (index (slot-index slot)))
	  (vector-ref (object-slots o) index))
	(and (eq? name 'traits)
	     (traits-for-primitive object-or-primitive)))))

(define (set-slot! object-or-primitive name value)
  (and-let* ((o (object-or-false object-or-primitive))
	     (slot (layout-ref (object-layout o) name #f))
	     (index (slot-index slot)))
    (let* ((slots (object-slots o))
	   (old-value (vector-ref slots index)))
      (vector-set! slots index value)
      old-value)))

(define (add-roles! name method specialisers)
  (if (replace-method! name specialisers method)
      method
      (let ((requirements (collect-bitset not-no-role? specialisers)))
	(for-each/index (lambda (index specialiser)
			  (when (not-no-role? specialiser)
			    (add-role! specialiser name #f index requirements method)))
			specialisers))))

;; (define-method! (union symbol string)
;;                 (list-of symbol)
;;                 (list-of object) - use *no-role* in this list if needed
;;                 procedure)
;;  -> method
;;
(define (define-method! name formal-names formal-specialisers body)
  (let* ((selector (if (string? name) (string->symbol name) name))
	 (method (make-method* selector formal-names body)))
    (add-roles!* selector #t method formal-specialisers)
    (invalidate-method-cache!)
    method))

;---------------------------------------------------------------------------

(define-record-type method-cache-entry
  (make-method-cache-entry selector layouts method)
  method-cache-entry?
  (selector method-cache-entry-selector)
  (layouts method-cache-entry-layouts)
  (method method-cache-entry-method))

(define *method-cache-length* 512)

(define *method-cache* 'uninitialised-method-cache)
(define (invalidate-method-cache!)
  (set! *method-cache* (make-vector *method-cache-length* '())))
(invalidate-method-cache!)

(define (object-layout-for-cache x)
  (object-layout (cond
		  ((object? x) x)
		  ((hash-table-ref *literal-objects* x #f))
		  (else (traits-for-primitive x)))))

(define (object-layout-hash-for-cache x)
  (layout-hash (object-layout-for-cache x)))

(define (probe-for-cache selector args)
  (bitwise-and (bitwise-xor (hash selector *method-cache-length*)
			    (object-layout-hash-for-cache (vector-ref args 0)))
	       (- *method-cache-length* 1)))

(define (check-method-cache selector args)
  (let* ((probe (probe-for-cache selector args))
	 (entry (vector-ref *method-cache* probe)))
    (and (method-cache-entry? entry)
	 (eq? (method-cache-entry-selector entry) selector)
	 (let ((n (vector-length args))
	       (layouts (method-cache-entry-layouts entry)))
	   (and (= n (vector-length layouts))
		(let loop ((i 0))
		  (cond
		   ((= i n) (method-cache-entry-method entry))
		   ((eq? (object-layout-for-cache (vector-ref args i)) (vector-ref layouts i))
		    (loop (+ i 1)))
		   (else #f))))))))

(define (cache-method! method selector args)
  (let* ((n (vector-length args))
	 (layouts (make-vector n))
	 (probe (probe-for-cache selector args)))
    (do ((i 0 (+ i 1)))
	((= i n))
      (vector-set! layouts i (object-layout-for-cache (vector-ref args i))))
    (vector-set! *method-cache* probe (make-method-cache-entry selector
							       layouts
							       method))))

;---------------------------------------------------------------------------

(define-record-type bitset
  (make-bitset* bits)
  bitset?
  (bits bitset-bits))

(define *bitset-capacity* 31)

(define-record-printer (bitset b out)
  (for-each (lambda (x) (display x out))
            (list "#<bitset "(bitset->list b)">")))

(define (bit-set? bitset n)
  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-bit-set?))
  (not (zero? (bitwise-and (bitset-bits bitset) (arithmetic-shift 1 n)))))

(define (set-bit bitset n)
  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-set-bit))
  (make-bitset* (bitwise-ior (bitset-bits bitset) (arithmetic-shift 1 n))))

(define (clear-bit bitset n)
  (if (>= n *bitset-capacity*) (error 'bitset-capacity-exceeded-in-clear-bit))
  (make-bitset* (bitwise-and (bitset-bits bitset) (bitwise-not (arithmetic-shift 1 n)))))

(define (bitset=? b1 b2)
  (= (bitset-bits b1)
     (bitset-bits b2)))

(define (bitset->list b)
  (filter (lambda (n) (bit-set? b n))
	  (iota *bitset-capacity*)))

(define (list->bitset l)
  (fold (lambda (bit acc) (set-bit acc bit))
	*empty-bitset*
	l))

(define *empty-bitset* (make-bitset* 0))

;---------------------------------------------------------------------------
;; Rank vectors.
;;
;; Representation: bitfield, 28 bits wide; bits numbered >= 28 must be zero.
;;  - room for 7 arguments numbered 0 through 6, inclusive
;;  - bits [4n, 4n+3] are the delegation-depth at the (6-n)th argument
;; Thus:
;;   33222222222211111111110000000000
;;   10987654321098765432109876543210
;;   --------------------------------
;;   xxxx0000111122223333444455556666

(define *illegal-rank-vector-bits* (arithmetic-shift -1 (* 4 7)))
(define *max-rank-vector* (bitwise-not *illegal-rank-vector-bits*))

(define (rank-vector-update rv delegation-depth arg-index)
  (let ((result (if (or (> delegation-depth 15)
			(> arg-index 6))
		    (error 'out-of-range-in-rank-vector-update (list delegation-depth arg-index))
		    (let ((offset (* 4 (- 6 arg-index))))
		      (bitwise-ior (bitwise-and rv
						*max-rank-vector*
						(bitwise-not (arithmetic-shift #xF offset)))
				   (arithmetic-shift delegation-depth offset))))))
    (debug 4 "rank-vector-update "(number->string rv 16)" "delegation-depth" "arg-index
	   " --> "(number->string result 16))
    (if (not (zero? (bitwise-and rv *illegal-rank-vector-bits*)))
	(error "Illegal rank vector"))
    result))

(define rank-vector<?
  (lambda (a b)
    (let ((result (< a b)))
      (debug 4 "rank-vector<? "(number->string a 16)" "(number->string b 16)" --> "result)
      result)))
(define rank-vector>?
  (lambda (a b)
    (let ((result (> a b)))
      (debug 4 "rank-vector>? "(number->string a 16)" "(number->string b 16)" --> "result)
      result)))

;---------------------------------------------------------------------------

(define (role-active-at-position? role position)
  (bit-set? (role-positions role) position))

(define (role-requirements-filled? role positions)
  (bitset=? positions (role-requirements role)))

;---------------------------------------------------------------------------

(define (dispatch ignored-method selector args)
  (or (and (not ignored-method)
	   (check-method-cache selector args))
      (if ignored-method
	  (dispatch* ignored-method selector args)
	  (and-let* ((method (dispatch* ignored-method selector args)))
	    (cache-method! method selector args)
	    method))))

(define (dispatch* ignored-method selector args)
  (debug 3 --> 0 "Dispatch "selector" "(vector-length args))
  (let* ((num-args (vector-length args))
	 (most-specific-method #f)
; 	 (DEBUG-ids (make-hash-table eq?))
; 	 (DEBUG-counter 10000)
; 	 (DEBUG-id (lambda (x) (or (hash-table-ref DEBUG-ids x)
; 				   (let ((c DEBUG-counter))
; 				     (set! DEBUG-counter (+ c 1))
; 				     (hash-table-set! DEBUG-ids x c)
; 				     c))))
	 (accessor-target #f)
	 (candidate-status (make-hash-table eq?))
	 (delegations-seen (make-hash-table eq?))
	 (rank-table (make-hash-table eq?))
	 (rank-vector-for (lambda (method deft) (hash-table-ref rank-table method deft))))
    (do ((arg-index 0 (+ arg-index 1)))
	((= arg-index num-args))
      (let search-delegates ((delegates (list (vector-ref args arg-index)))
			     (delegation-depth 0))
	(unless (null? delegates)
	  (let* ((maybe-primitive-delegate (car delegates))
		 (delegate (let ((d maybe-primitive-delegate))
			     (ensure-object-var/traits d)
			     d))
		 (remaining-delegates (cdr delegates))
		 (delegate-layout (object-layout delegate))
		 (selected-slot (layout-ref delegate-layout selector #f)))
;	    (debug 1 --> 0 "Inspecting "maybe-primitive-delegate" resolving to "delegate)
;	    (debug 6 --> 0 "Inspecting "(DEBUG-id delegate)
;		   " slot "selected-slot" depth "delegation-depth" arg index "arg-index)
	    (when selected-slot
	      (for-each (lambda (role)
			  (when (role-active-at-position? role arg-index)
			    (let* ((method (role-method role))
				   (rankvec0 (rank-vector-for method *max-rank-vector*))
				   (rankvec (rank-vector-update
					     rankvec0 delegation-depth arg-index))
				   (positions0 (hash-table-ref
						candidate-status method *empty-bitset*))
				   (positions (set-bit positions0 arg-index)))
			      (hash-table-set! rank-table method rankvec)
			      (hash-table-set! candidate-status method positions)
			      (when (and (role-requirements-filled? role positions)
					 (or (not ignored-method)
					     (rank-vector>? rankvec
							    (rank-vector-for ignored-method -1)))
					 (or (not most-specific-method)
					     (rank-vector<? rankvec
							    (rank-vector-for
							     most-specific-method -1))))
				(cond
				 ((eq? (get-slot method 'accessor) *nil*)
				  (set! accessor-target #f))
				 ((= arg-index 0)
				  (set! accessor-target maybe-primitive-delegate)))
				(set! most-specific-method method)))))
			(slot-roles selected-slot)))
	    (layout-for-each delegate-layout
	     (lambda (slot-name slot)
	       (and-let* ((_		(slot-delegating? slot))
			  (new-delegate	(vector-ref (object-slots delegate) (slot-index slot)))
			  (_		(not (eq? new-delegate *nil*)))
			  (seen-in-positions (hash-table-ref delegations-seen new-delegate
							     *empty-bitset*))
			  (_		(not (bit-set? seen-in-positions arg-index))))
		 (hash-table-set! delegations-seen new-delegate
				  (set-bit seen-in-positions arg-index))
;		 (debug 6 --> 0 "Delegating via "slot-name" of "(DEBUG-id delegate)
;			" to "(DEBUG-id new-delegate) " at level "delegation-depth" pos "arg-index)
		 (set! remaining-delegates (cons new-delegate remaining-delegates)))))
	    (search-delegates remaining-delegates (+ delegation-depth 1))))))
    (if most-specific-method
	(begin
	  (when accessor-target
	    (vector-set! args 0 accessor-target))
	  most-specific-method)
	#f)))