;;;
;;; bootstrap.lisp
;;;
;;; Initial smalltalk image bootstrap machinery.
;;;

(cl:defpackage :speakeasy
  (:use :cl))
(cl:in-package :speakeasy)

;;; Guaranteed pointers (from the blue book)
;;
;; Some of these are only used in primitive activation, particularly
;; for the UI methods.
;;
;; 0: ???
;; 2: nil
;; 4: False
;; 6: True
;; 8: SchedulerAssociation (the Association in Smalltalk for Processor)
;; 10: ???
;; 12: ???
;; 14: ClassString
;; 16: ClassArray
;; 18: ???
;; 20: ???
;; 22: ClassMethodContext
;; 24: ClassBockContext
;; 26: ClassPoint
;; 28: ClassLargePositiveInteger
;; 30: ???
;; 32: ClassMessage
;; 34: ???
;; 36: ???
;; 38: ???
;; 40: ClassCharacter
;; 42: #doesNotUnderstand:
;; 44: #cannotReturn:
;; 46: ???
;; 48: SpecialSelectors
;; 50: CharacterTable
;; 52: #mustBeBoolean
;;
;; As we are not expecting true ST-80 image compatability, we don't
;; need to treat this as more than a guideline.  Additionally, since
;; we're bootstrapping our own image, we can use variables instead of
;; constants for these values, and just populate them as they are
;; defined.

(defun panic (reason)
  "When in danger, when in doubt: Run in circles, scream and shout!"
  (break reason))

;;;
;;; The object table
;;;

;; An object table entry

(defstruct ote
  class
  data
  pointers
  words
  odd-length)

;; The object table is an array containing information about every
;; object in the system.  It is indexed by (ash oop -1).
;;
;; Each allocated object is represented by an OTE.  Free entries are
;; integers representing a freelist, or NIL representing the end of
;; the freelist.

(defvar *object-table* (make-array #x8000 :initial-element nil))
(defvar *next-free-oop* 0)

;; Initialize the freelist.

(defun clear-object-memory ()
  (setf *next-free-oop* 0)
  (dotimes (i #x7fff)
    (setf (aref *object-table* i) (ash (1+ i) 1))))

;;;
;;; Known OOPs.
;;;

;; "Known" OOPs need placeholder values until their objects have
;; actually been defined.  In some cases, we arrange for them to be
;; defined before use, in others, we backpatch (such as for known
;; classes, as that's an easy fixup).  We will be attempting to avoid
;; backpatching non-class fields, as doing a full image search for a
;; given OOP is more code to write and would of necessity be slower
;; than scanning the class fields of the object table.

(defvar +smalltalk-oop+)
(defvar +nil-oop+)
(defvar +false-oop+)
(defvar +true-oop+)
(defvar +does-not-understand-oop+)
(defvar +cannot-return-oop+)
(defvar +must-be-boolean-oop+)
(defvar +character-table-oop+)

(defvar +array-class-oop+ 'array)
(defvar +symbol-class-oop+ 'symbol)
(defvar +association-class-oop+ 'association)
(defvar +identity-dictionary-class-oop+ 'identity-dictionary)
(defvar +dictionary-class-oop+ 'dictionary)
(defvar +character-class-oop+ 'character)
(defvar +metaclass-class-oop+ 'metaclass)
(defvar +compiled-method-class-oop+ 'compiled-method)

(defun reset-known-oops ()
  (makunbound '+smalltalk-oop+)
  (makunbound '+nil-oop+)
  (makunbound '+false-oop+)
  (makunbound '+true-oop+)
  (makunbound '+does-not-understand-oop+)
  (makunbound '+cannot-return-oop+)
  (makunbound '+must-be-boolean-oop+)
  (makunbound '+character-table-oop+)

  (setf +array-class-oop+ 'array)
  (setf +symbol-class-oop+ 'symbol)
  (setf +association-class-oop+ 'association)
  (setf +identity-dictionary-class-oop+ 'identity-dictionary)
  (setf +dictionary-class-oop+ 'dictionary)
  (setf +character-class-oop+ 'character)
  (setf +metaclass-class-oop+ 'metaclass)
  (setf +compiled-method-class-oop+ 'compiled-method)
  )

;;;
;;; Object allocation and creation.
;;;

(defun allocate-oop ()
  "Obtain an un-allocated OOP for use."
  (prog1
      *next-free-oop*
    (when (not (setf *next-free-oop* (aref *object-table* (ash *next-free-oop* -1))))
      ;;; Oops: Out of OOPs. We really should GC here, but meanwhile...
      (panic "No free OOPs"))))

(defun make-object (oop type length class)
  "Create an OTE for a given OOP, allocating required data space."
  (when (ote-p (aref *object-table* (ash oop -1)))
    (panic "make-object overwriting existing OTE"))
  (setf (aref *object-table* (ash oop -1))
	(make-ote :class class
		  :pointers (eql type :pointers)
		  :words (eql type :words)
		  :odd-length (and (eql type :bytes)
				   (oddp length))
		  :data (make-array (if (eql type :bytes)
					(ash (1+ length) -1)
					length)
				    :element-type '(unsigned-byte 16)
				    :initial-element (if (eql type :pointers)
							 +nil-oop+
							 0)))))

;;;
;;; Object data access.
;;;

(defmacro with-ote ((var oop) &body body)
  ;; FIXME: Should probably validate that oop isn't a SmallInteger.
  `(let ((,var (aref *object-table* (ash ,oop -1))))
     (unless (ote-p ,var) (panic "Accessing non-allocated object"))
     ,@body))

(defun obj-byte (oop index)
  (with-ote (ob oop)
    (ldb (byte 8 (ash (logand index 1) 3))
	 (aref (ote-data ob) (ash index -1)))))

(defun (setf obj-byte) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) (ash index -1))
	  (dpb value
	       (byte 8 (ash (logand index 1) 3))
	       (aref (ote-data ob) (ash index -1)))))
  value)

(defun obj-word (oop index)
  (with-ote (ob oop)
    (aref (ote-data ob) index)))

(defun (setf obj-word) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) index) value)))

;; These next two are hooks to support refcounting.

(defun obj-oop (oop index)
  (with-ote (ob oop)
    (aref (ote-data ob) index)))

(defun (setf obj-oop) (value oop index)
  (with-ote (ob oop)
    (setf (aref (ote-data ob) index) value)))

(defun box-integer (value)
  ;; FIXME: Only works on SmallIntegers, no error checking.
  (logior 1 (ash value 1)))

;;;
;;; Symbol access.
;;;

(defvar *symbol-mapping* (make-hash-table :test 'equal))

(defun find-symbol-in-image (name)
  "Look through all Symbols in the system looking for one matching NAME."
  (dotimes (i #x8000)
    (let ((ob (aref *object-table* i)))
      (when (and (ote-p ob)
		 (eql (ote-class ob) +symbol-class-oop+)
		 (= (length (ote-data ob)) (ash (1+ (length name)) -1))
		 (eql (ote-odd-length ob) (oddp (length name))))
	;; We have an allocated object, that is a symbol, and is the
	;; same length as the name.  Now check we the actual data.
	(loop for j from 0 below (length name)
	      when (/= (obj-byte (ash i 1) j) (char-code (aref name j)))
	      return nil
	      finally (return-from find-symbol-in-image (ash i 1)))))))

(defun create-symbol (name)
  "Create a new Symbol in the system called NAME."
  (let ((oop (allocate-oop)))
    (make-object oop :bytes (length name) +symbol-class-oop+)
    (dotimes (i (length name))
      (setf (obj-byte oop i) (char-code (aref name i))))
    oop))

(defun intern-symbol (name)
  "Find a Symbol for NAME, creating one if necessary."
  (or (gethash name *symbol-mapping*)
      (setf (gethash name *symbol-mapping*)
	    (or (find-symbol-in-image name)
		(create-symbol name)))))

;;;
;;; IdentityDictionary (method dictionary) access.
;;;

;; An IdentityDictionary is supposed to be a subclass of Set.  It has
;; two fixed fields (a count of the number of methods and an Array of
;; the actual methods) and stores the method selectors in its indexed
;; fields.  This is probably one of the "implementation convenience"
;; nastinesses in the Smalltalk-80 class hierarchy, as I can't see how
;; Set would work given the way the method selectors are arranged
;; within the indexed fields.

;; Complexities here include resizing the dictionary when it gets too
;; full, and a good notion of what "too full" is.

(defun create-method-dictionary (&key (size 16))
  (let ((method-array (allocate-oop))
	(dictionary (allocate-oop)))
    (make-object method-array :pointers size +array-class-oop+)
    (make-object dictionary :pointers (+ size 2) +identity-dictionary-class-oop+)
    (setf (obj-oop dictionary 0) (box-integer 0))
    (setf (obj-oop dictionary 1) method-array)
    dictionary))

;; There's supposed to be some sort of hashing logic based on the
;; message selector OOP for finding the method.  In the interests of
;; getting this working, we'll go with a linear scan for now.

;; XXX: Would these be better as a dictionary-method accessor?

(defun lookup-method-in-dictionary (dictionary selector)
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    return (obj-oop (aref data 1) i)))))

(defun add-method-to-dictionary (dictionary selector method)
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    do (setf (obj-oop (aref data 1) i) method)
	       (return)
	    finally
	    ;; FIXME: Check for incipient dictionary overflow.
	    ;;(when )
	    (loop for i below length
		  when (= (aref data (+ i 2)) +nil-oop+)
		  do (setf (obj-oop (aref data 1) i) method)
		     (setf (aref data (+ i 2)) selector)
		     (return)))))
  method)

(defun remove-method-from-dictionary (dictionary selector)
  ;; More for completeness sake than anything else.
  (with-ote (dict dictionary)
    (let* ((data (ote-data dict))
	   (length (- (length data) 2)))
      (loop for i below length
	    when (= (aref data (+ i 2)) selector)
	    do (setf (obj-oop (aref data 1) i) +nil-oop+)
	       (setf (aref data (+ i 2)) +nil-oop+)))))

;;;
;;; Dictionary (system dictionary (Smalltalk) and pool variable) access.
;;;

(defun association-key (oop)
  (obj-oop oop 0))

(defun (setf association-key) (value oop)
  (setf (obj-oop oop 0) value))

(defun association-value (oop)
  (obj-oop oop 1))

(defun (setf association-value) (value oop)
  (setf (obj-oop oop 1) value))

(defun make-association (key value)
  (let ((association (allocate-oop)))
    (make-object association :pointers 2 +association-class-oop+)
    (setf (association-key association) key)
    (setf (association-value association) value)
    association))

;; The accessors for a Dictionary are similar to those for an
;; IdentityDictionary, only the key/value pairs are stored in an
;; Association instead of split over the dictionary and an Array of
;; values.  Similar auto-resizing and hashing rules apply (including
;; the bit about not implementing the hashing yet).

(defun create-dictionary ()
  (let ((dictionary (allocate-oop)))
    (make-object dictionary :pointers 16 +dictionary-class-oop+)
    dictionary))

(defun dictionary-association-at (dictionary key)
  (with-ote (ob dictionary)
    (let ((data (ote-data ob)))
      (loop for entry across data
	    when (and (not (= entry +nil-oop+))
		      (= (association-key entry) key))
	    return entry))))

(defun dictionary-at (dictionary key)
  (association-value (dictionary-association-at dictionary key)))

(defun dictionary-add-association (dictionary association)
  ;; We are adding a new Association.  It has already been built, and
  ;; is not a duplicate of an existing entry.
  (with-ote (ob dictionary)
    (let ((data (ote-data ob)))
      (loop for entry across data
	    for index from 0
	    when (= entry +nil-oop+)
	    return (setf (aref data index) association)
	    finally
	    ;; Grow the Dictionary.  Theoretically, we should rehash here.
	    (let ((new-data (make-array (* 2 (length data))
					:element-type '(unsigned-byte 16)
					:initial-element +nil-oop+)))
	      (setf (ote-data ob) new-data)
	      (setf (subseq new-data 0) data)
	      (setf (aref new-data (length data)) association))))))

(defun dictionary-at-put (dictionary key value)
  (let ((entry (dictionary-association-at dictionary key)))
    (if entry
	(setf (association-key entry) value)
	(dictionary-add-association dictionary (make-association key value)))))

;;;
;;; Classes.
;;;

;; As far as the VM is concerned, a class consists of a superclass, a
;; method dictionary and an instance specification (a SmallInteger).
;; This much is defined in class Behavior (three instance variables).

(defconstant +superclass-ofs+ 0)
(defconstant +method-dictionary-ofs+ 1)
(defconstant +instance-spec-ofs+ 2)

;; Layered over this is ClassDescription, which adds names for the
;; class and instance variables, comments, and grouping methods into
;; categories (call it four more instance variables; one for the class
;; name, one for the collection of instance variable names (an
;; Array?), one for the class comment, and one for some structure for
;; grouping the methods).

;; The next layer is Metaclass and Class.

;; As far as instance variabes go, Class has an additional one to hold
;; the class variable pool.

(defconstant +class-pool-ofs+ 7)

;; When a new class is created, the superclass is sent a message
;; indicating that a new subclass is wanted with a given name and
;; certain properties (instance variables, pools, etc.).  The
;; superclass turns around and sends a message to Metaclass asking for
;; a new metaclass to be created for the new subclass.  Metaclass then
;; creates the new metaclass for the new class and sends it a message
;; requesting that it create the new class.  I don't know if this is a
;; spiral dance, an innocent dance, or what, but it's certainly an
;; -intricate- dance.

;; For bootstrapping purposes, we accept two types of value for a
;; superclass.  The first is nil, used as Object's superclass.  The
;; second is a string, which is converted to a symbol OOP and looked
;; up in the system dictionary in order to find the corresponding
;; class OOP.

;; Interestingly, as every class's metaclass's class is supposed to be
;; Metaclass, including Metaclass itself, everything but Object's
;; metaclass being a subclass of Class is covered by the class
;; placeholder fixup mechanism.

(defun define-class (superclass name &key inst-vars class-vars (encoding :pointer))
  (let* ((superclass-oop (if superclass
			     (dictionary-at +smalltalk-oop+
					    (intern-symbol superclass))
			     +nil-oop+))
	 (supermeta-oop (if superclass
			    (ote-class (aref *object-table*
					     (ash superclass-oop -1)))
			    ;; If we have no superclass, this is
			    ;; supposed to be the OOP of Class, but
			    ;; since we are, by definition, defining
			    ;; Object we haven't defined Class yet, so
			    ;; we'll have to backpatch this later.
			    +nil-oop+))
	 (metaclass-oop (allocate-oop))
	 (class-oop (allocate-oop))
	 (superclass-instance-spec (if superclass
				       (obj-oop superclass-oop +instance-spec-ofs+)
				       #x8001))
	 (inherited-vars (ldb (byte 11 1) superclass-instance-spec)))

    (when (and (member encoding '(:variable-byte :variable-word))
	       (or (> inherited-vars 0)
		   inst-vars))
      (panic "non-pointer class definition has instance variables"))

    (make-object metaclass-oop :pointers 7 +metaclass-class-oop+)
    (setf (obj-oop metaclass-oop +superclass-ofs+) supermeta-oop)
    (setf (obj-oop metaclass-oop +method-dictionary-ofs+) (create-method-dictionary))
    (setf (obj-oop metaclass-oop +instance-spec-ofs+) (box-integer (logior #x4000 7)))

    (make-object class-oop :pointers 8 metaclass-oop)
    (setf (obj-oop class-oop +superclass-ofs+) superclass-oop)
    (setf (obj-oop class-oop +method-dictionary-ofs+) (create-method-dictionary))
    (setf (obj-oop class-oop +instance-spec-ofs+)
	  (box-integer (logior
			(ecase encoding
			  (:pointer #x4000)
			  (:variable #x5000)
			  (:variable-byte #x1000)
			  (:variable-word #x3000))
			(+
			 inherited-vars
			 (length inst-vars)))))
    (when class-vars
      (let ((pool (create-dictionary)))
	(setf (obj-oop class-oop +class-pool-ofs+) pool)
	(dolist (var class-vars)
	  (dictionary-at-put pool (intern-symbol var) +nil-oop+))))

    (dictionary-at-put +smalltalk-oop+ (intern-symbol name) class-oop)))

;; Because we need to create objects well before we can create
;; classes, we use symbolic placeholders for some object classes.
;; Once the actual classes are defined we need to fixup the references
;; to the placeholder to point to the actual class instead.

(defun class-fixup (old-class new-class-name)
  "Fixup class references to OLD-CLASS in the object table to point to NEW-CLASS instead."
  (let ((new-class (dictionary-at +smalltalk-oop+
				  (intern-symbol new-class-name))))
    (loop for ob across *object-table*
	  when (and (ote-p ob)
		    (eql old-class (ote-class ob)))
	  do (setf (ote-class ob) new-class))
    new-class))

;;;
;;; Compiled methods.
;;;

;; Compiled methods are the weirdest objects in Smalltalk.  They
;; combine an indexed pointer data area with an indexed byte data area
;; (the only class to do so), and have two "special" locations within
;; the litera area that have special uses.  The last literal slot is
;; used, in methods which use a super-send bytecode, to hold the
;; Association from the system dictionary between the class name and
;; the class.  The next-to-last literal slot holds a header extension
;; word in those methods which require it (those with associated
;; primitive routines or requiring more than four arguments).

;; As laying out methods by hand would be tedious at best, the current
;; thought is to write a compiler in Lisp for bootstrap purposes (if
;; not production use).

;; This is a low-level pure object-creation function.  It doesn't do
;; any hand-holding like setting the method class for methods using
;; super sends, setting header extensions, declarative header
;; creation, setting the method up in a method dictionary, or anything
;; like that.  The only hand-holding it does is to set the literal
;; count of the header from the length of the list of literals passed.
(defun create-method (header literals bytecode)
  (let ((oop (allocate-oop))
	(length (1+ (+ (length literals)
		       (ash (1+ (length bytecode)) -1))))
	(bytecode-start (ash (1+ (length literals)) 1)))

    (make-object oop :pointers length +compiled-method-class-oop+)

    (setf (obj-oop oop 0) (dpb (length literals) (byte 6 1) header))

    (loop for literal in literals
	  for index from 1
	  do (setf (obj-oop oop index) literal))

    (loop for byte across bytecode
	  for index from bytecode-start
	  do (setf (obj-byte oop index) byte))

    oop))

;;;
;;; Building the virtual image.
;;;

(progn
  ;; Reset the object memory and known pointers.
  (clear-object-memory)
  (reset-known-oops)
  (setf *symbol-mapping* (make-hash-table :test 'equal))

  ;; Preset +nil-oop+ so we can run create-dictionary.
  (setf +nil-oop+ 2)

  ;; Smalltalk
  (setf +smalltalk-oop+ (create-dictionary))
  (with-ote (ob +smalltalk-oop+)
    ;; Special case dictionary.
    (setf (ote-class ob) 'system-dictionary))

  ;; nil
  (assert (= +nil-oop+ (allocate-oop)))
  (make-object +nil-oop+ :pointers 0 'undefined-object)

  ;; False
  (setf +false-oop+ (allocate-oop))
  (make-object +false-oop+ :pointers 0 'false)
  
  ;; True
  (setf +true-oop+ (allocate-oop))
  (make-object +true-oop+ :pointers 0 'true)

  ;; Known method selectors.
  (setf +does-not-understand-oop+ (intern-symbol "doesNotUnderstand:"))
  (setf +cannot-return-oop+ (intern-symbol "cannotReturn:"))
  (setf +must-be-boolean-oop+ (intern-symbol "mustBeBoolean"))

  ;; Globals thus far allocated.
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "Smalltalk") +smalltalk-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "nil") +nil-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "false") +false-oop+)
  (dictionary-at-put +smalltalk-oop+ (intern-symbol "true") +true-oop+)

  ;; Initial class/metaclass hierarchy setup.
  (define-class nil "Object")
  (define-class "Object" "Behavior" :inst-vars '("superclass" "methodDictionary" "instanceSpec"))
  (define-class "Behavior" "ClassDescription" :inst-vars '("name" "comment" "instVars" "methodCategories"))
  (define-class "ClassDescription" "Class" :inst-vars '("classPool"))
  (define-class "ClassDescription" "Metaclass")

  ;; Fix Object class superclass (is nil during creation).
  (with-ote (obj (dictionary-at +smalltalk-oop+ (intern-symbol "Object")))
    (setf (obj-oop (ote-class obj) +superclass-ofs+)
	  (dictionary-at +smalltalk-oop+ (intern-symbol "Class"))))

  ;; Control flow classes.
  (define-class "Object" "Boolean")
  (define-class "Boolean" "False")
  (define-class "Boolean" "True")
  (define-class "Object" "UndefinedObject")

  ;; Numberish things.
  (define-class "Object" "Magnitude")
  (define-class "Magnitude" "Character" :encoding :variable-byte)
  (define-class "Magnitude" "Number")
  (define-class "Number" "Integer")
  (define-class "Integer" "SmallInteger")
  ;; FIXME: Float, Fraction, Date, Time, LargeNegativeInteger and
  ;; LargePositiveInteger go here.
  (define-class "Magnitude" "LookupKey")
  (define-class "LookupKey" "Association" :inst-vars '("key" "value"))

  ;; Collection classes.
  (define-class "Object" "Collection")
  (define-class "Collection" "SequencableCollection")
  (define-class "SequencableCollection" "ArrayedCollection")
  (define-class "ArrayedCollection" "Array" :encoding :variable)
  (define-class "ArrayedCollection" "String" :encoding :variable-byte)
  (define-class "String" "Symbol" :encoding :variable-byte)
  (define-class "Collection" "Set" :encoding :variable :inst-vars '("tally"))
  (define-class "Set" "Dictionary" :encoding :variable)
  (define-class "Dictionary" "IdentityDictionary" :encoding :variable
		:inst-vars '("values"))
  (define-class "Dictionary" "SystemDictionary" :encoding :variable)

  ;; CharacterTable and the Characters.
  (setf +character-table-oop+ (allocate-oop))
  (make-object +character-table-oop+ :pointers 256 +array-class-oop+)

  (loop for char across (concatenate 'string
				     ;; Hopefully all of the important ones.
				     "0123456789"
				     "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
				     "abcdefghijklmnopqrstuvwxyz"
				     "+/\\*~<>=@%|&?!"
				     "[]{}()_^,;$#:"
				     "'\"-.")
	for oop = (allocate-oop)
	do
	(make-object oop :bytes 1 +character-class-oop+)
	(setf (obj-byte oop 0) (char-code char))
	(setf (obj-oop +character-table-oop+ (char-code char)) oop))

  ;; Methods.
  (define-class "Object" "CompiledMethod" :inst-vars '(header) :encoding :variable)

  ;; Snap all placeholder class links.
  (class-fixup 'undefined-object "UndefinedObject")
  (class-fixup 'false "False")
  (class-fixup 'true "True")
  (class-fixup 'system-dictionary "SystemDictionary")

  (setf +array-class-oop+ (class-fixup 'array "Array"))
  (setf +symbol-class-oop+ (class-fixup 'symbol "Symbol"))
  (setf +association-class-oop+ (class-fixup 'association "Association"))
  (setf +identity-dictionary-class-oop+ (class-fixup 'identity-dictionary "IdentityDictionary"))
  (setf +dictionary-class-oop+ (class-fixup 'dictionary "Dictionary"))
  (setf +character-class-oop+ (class-fixup 'character "Character"))
  (setf +metaclass-class-oop+ (class-fixup 'metaclass "Metaclass"))
  (setf +compiled-method-class-oop+ (class-fixup 'compiled-method "CompiledMethod"))

  ;; Initial method load.

  ;; Scheduler setup and initial task.
)

;;; EOF