" Smalltalk/runtime.st -- runtime support for the idst object model		-*- Smalltalk -*- "

" ---------------------------------------------------------------- "
" Part 0 -- Runtime objects                                        "
" ---------------------------------------------------------------- "

" Create the root prototype, from which every object is derived.
  (Multiple 'root' prototypes in user-level hierarchies are all
  actually derived from _object.  This is essential because _object
  provides the protocol necessary for cloning, prototype derivation,
  method dictionary manipulation, and message lookup.) "

_object ()

" This prototype _object is in a clone family derived from (delegating
  to) that of the intrinsic _object; pull the new _object up into the
  real _object's clone family by installing its delegate as its
  vtbl. "

[ _object _vtbl: _object _vtbl delegate ]

" Accessing members common to all objects.  Object pointers point to
  the first data slot in an object.  The virtual table for the object
  is in the word preceding the object's slots.  (IOW, oops point one
  word past the vtbl.  This allows toll-free 'bridging' to C/C++
  structs/classes and Obj-C objects by allocating a vtbl word before
  the C/C++/ObjC object address, effectively 'wrapping' the foreign
  object in an idst object whose layout is identical to [and stored in
  the same locations as] the foreign object.) "

_object _debugName	{ return (oop)"_object" }
_object _sizeof		{ return (oop)sizeof(struct t__object) }

_object _vtbl		{ return (oop)(self->_vtbl[-1]) }
_object _vtbl: vt	{ return (oop)(self->_vtbl[-1]= (vtbl_t)v_vt) }

" Virtual tables.  Akin to method dictionaries. "

_vtbl : _object
(
  size		"the number of bindings in the _bindings vector"
  capacity	"the capacity of the _bindings vector"
  _bindings	"vector (association list) of _binding objects (see below)"
  delegate	"the _vtbl to which unimplemented messages are forwarded"
)

" The _vtbl prototype just created belongs to an empty clone family of
  no interest whatsoever.  Its vtbl, however, is a live object
  belonging to (and a perfectly serviceable prototype for) the real
  clone family containing all vtbls.  Overwrite _vtbl with its own
  vtbl to create a useful prototype for all vtbl behaviour."

[ _vtbl := _vtbl _vtbl ]

_vtbl _debugName	{ return (oop)"_vtbl" }
_vtbl _sizeof		{ return (oop)sizeof(struct t__vtbl) }

_vtbl delegate		[ ^delegate ]
_vtbl delegate: vtbl	[ ^delegate := vtbl ]
_vtbl size		[ ^size ]

" Accessing bindings within a vtable. "

_vtbl bindingAt: index
[
    {
      struct t__vtbl *this= (struct t__vtbl *)self;
      if (_isIntegerObject(v_index) && ((unsigned)v_index < (unsigned)this->size))
        return ((oop *)(this->_bindings))[_integerValue(v_index)];
    }.
    ^self primitiveFailed
]

_vtbl bindingAt: index put: aBinding
[
    {
      struct t__vtbl *this= (struct t__vtbl *)self;
      if (_isIntegerObject(v_index) && ((unsigned)v_index < (unsigned)this->size))
        return ((oop *)(this->_bindings))[_integerValue(v_index)]= v_aBinding;
    }.
    ^self primitiveFailed
]

" Bindings.  An association between a selector and a method in a
  virtual table '_bindings' vector. "

_binding : _object
(
  selector	"the selector (see below)"
  _method	"raw pointer to method entry point"
)

" Again, the prototype _binding just created is in a clone family of
  its own.  The first binding in any existing vtbl is in the correct
  clone family, so move _binding explicitly to that family. "

[ _binding _vtbl: (_vtbl bindingAt: 0) _vtbl ]

_binding _debugName	{ return (oop)"_binding" }
_binding _sizeof	{ return (oop)sizeof(struct t__binding) }

_binding selector	[ ^selector ]
_binding _method	[ ^_method ]
_binding _method: _meth	[ ^_method := _meth ]

" Selectors.  Selectors are similar to Symbols (interned Strings),
  beginning like a byte array but adding a field 'next' through which
  all clones are linked. "

_selector : _object
(
  size		"the size (in bytes) of the _name"
  _name		"a C string (nul-terminated) containing the _selector's name"
  next		"the next _selector in the list of all _selectors"
)

" As before, the _selector prototype is not in the right family.  Grab
  a real _selector from a handy place and move the prototype into its
  family. "

[ _selector _vtbl: (_vtbl bindingAt: 0) selector _vtbl ]

_selector _debugName	{ return (oop)"_selector" }
_selector _sizeof	{ return (oop)sizeof(struct t__selector) }

_selector size		[ ^size ]
_selector name		[ ^String _value: _name ]
_selector next		[ ^next ]
_selector next: sel	[ ^next := sel ]


" ---------------------------------------------------------------- "
" Part 1 -- Creating clones and prototypes                         "
" ---------------------------------------------------------------- "

" Answer the receiver's slot size in bytes. "

_object sizeof
[
    ^SmallInteger _value: self _sizeof
]

" Anwer a primitive (non-object) vector of pointers (i.e., one in
  which each word is considered a potential pointer by the gargage
  collector). "

_object _newPointers: size
{
  return _newPointers(_integerValue(v_size));
}

" Cloning the receiver.  Answer a new object, with identical behaviour
  as the receiver, with _size bytes of (uninitialised) space in the
  new object's body (usually occupied by its named slots).

  NOTE: This method can be invoked many millions of times per second,
  so it's almost reasonable to write it primitively (avoiding two
  additional message sends) even though the only reason to do so is
  performance. "

_object _clone: _size			"_size is a primitive int"
{
  vtbl_t *clone= (vtbl_t *)_newPointers(sizeof(vtbl_t) + (int)v__size);
  *clone= self->_vtbl[-1];
  return (oop)(clone + 1);
}

_object _clone
[
    ^self _clone: self _sizeof		"clone to the object's self-advertised slots size"
]

" Creating a prototype for a new clone family.  Answer a prototype for
  a new clone family whose clones delegate to the receiver."

_object _delegated
[
    "create derived vtbl, then allocate an object from it"
    ^(self == nil ifTrue: [_object] ifFalse: [self]) _vtbl delegated allocate: nil
]

" Creating a derived vtable for a new clone family.  Answer an empty
  vtbl that delegates unknown messages to the receiver. "

_vtbl delegated
[
    | parent |
    parent := self.
    self := self _clone.
    size      := 0.
    capacity  := 2.
    _bindings := _object _newPointers: _binding sizeof * capacity.
    delegate  := parent.
    "sparse arrays are not (yet) real objects -- have to initialise
     the per-clone family method array primitively.  sigh... "
    {
#    if (VTBL_CACHE)
#     error: redefine _vtbl() to include the additional slots for the selector cache!
      vtbl->cache = array_new(0);	/* a sparse array mapping selector index -> method */
      vtbl->next  = vtbl_List;		/* push the new vtbl onto the vtbl list */
      vtbl_List   = (vtbl_t)self;
#    endif
    }
]

" Creating objects within a clone family.  Answer a new object whose
  behaviour is defined by (vtbl is) the receiver, with _size bytes of
  space for the new object's slots.

  NOTE: this is written primitively only to avoid some ugliness with
  doing pointer arithmetic non-primitively. "

_vtbl allocate: _size
{
  vtbl_t *chunk= (vtbl_t *)_newPointers(sizeof(vtbl_t) + (int)v__size);
  *chunk= (vtbl_t)self;
  return (oop)(chunk + 1);
}

" Declaring a clone family to be tagged (non-aligned oops) or nil (oop
  is zero). "

_vtbl beNilType		{ vtbl_Nil= (vtbl_t)self }
_vtbl beTaggedType	{ vtbl_Tagged= (vtbl_t)self }

_object _beNilType	[ self _vtbl beNilType]
_object _beTaggedType	[ self _vtbl beTaggedType]


" ---------------------------------------------------------------- "
" Part 2 -- Manipulating object behaviour                          "
" ---------------------------------------------------------------- "

" Resize a previously-allocated aread of memory. "

_object _realloc: _pointer size: size
{
  return _realloc(v__pointer, _integerValue(v_size));
}

" Double the capacity of the receiver's binding table.  (This method
  must be defined before invoking '_vtbl at:put:'.) "

_vtbl grow				"xxx NOT THREAD SAFE xxx"
[
    capacity := capacity * 2.
    _bindings := _object _realloc: _bindings size: _binding sizeof * capacity.
]

" Answer a new binding with the given selector and method. "

_binding newSelector: aSelector method: _aMethod
[
    self := self _clone.
    selector := aSelector.
    _method := _aMethod.
]

" Associate aSelector with _aMethod in the receiver.

  NOTE: Every addition of a method to a vtbl comes through this
  method. "

_vtbl at: aSelector put: _aMethod	"xxx NOT THREAD SAFE xxx"
[
    | index done |
    index := 0.
    done := nil.
    [index < self size and: [done == nil]]
	whileTrue:
	    [| binding |
	     binding := self bindingAt: index.
	     binding selector == aSelector ifTrue: [done := binding _method: _aMethod].
             index := index + 1].
    done
	ifFalse:
	    [(size == capacity) ifTrue: [self grow].
	     size := size + 1.
	     self bindingAt: size - 1 put: (_binding newSelector: aSelector method: _aMethod)].
    ^_aMethod
]

_vtbl at: aSelector
[
    | index found |
    index := 0.
    found := nil.
    [index < self size and: [found == nil]]
	whileTrue:
	    [| binding |
	     binding := self bindingAt: index.
	     binding selector == aSelector ifTrue: [found := binding _method].
             index := index + 1].
    ^found
]

" Associate aSelector with aMethod for all objects in the receiver's
  clone family.

  NOTE: Every addition of a method to an object's protocol comes
  through this method. "

_object _methodAt: aSelector put: _aMethod
[
    ^self _vtbl at: aSelector put: _aMethod
]

" Flushing the method caches.  After replacing or removing a method,
  send the following to make sure the change is effective throughout
  the system.

  NOTE: Not needed during monotonic addition (e.g., when initialising
  entire protocols at startup). "

_vtbl flushCache
{
  flushCache();    /* flushes all method caches (global, vtbl, inline, whatever...) */
}

" Creating new selectors.  Answer a _selector with the given name.  If
  the selector was already present in the system, answer the existing
  selector.  Otherwise create a new selector and add it to the list of
  all selectors. "

_selector _value: _cString
[
    self := self _clone.
    {
      struct t__selector *this= (struct t__selector *)self;
      char *string= (char *)v__cString;
      int size= strlen(string);
      this->size=  _integerObject(size);
      this->_name= _newBytes(size + 1);
      memcpy(this->_name, string, size);
      ((char *)this->_name)[size]= '\0';
      this->next= 0;
    }
]

_object is_selector	[ ^false ]
_selector is_selector	[ ^true ]
_selector _stringValue	[ ^_name ]
_selector _cString	[ ^_name ]

_object _memcmp: b1 with: b2 length: len
{
  return _integerObject(memcmp(v_b1, v_b2, _integerValue(v_len)));
}

_selector = aSelectorOrString
[
    ^size == aSelectorOrString size and: [(_object _memcmp: _name with: aSelectorOrString _stringValue length: size) == 0]
]

_selector list		{ return (oop)(_sel_List); }
_selector list: sel	{ return (oop)(_sel_List= (sel_t)v_sel); }


" Answer a unique _selector with the given name. "

_selector intern: aSelectorOrString
[
    | selector found |
    selector := _selector list.
    found := nil.
    [selector == nil]
	whileFalse:
	    [selector = aSelectorOrString
		 ifTrue:
		     [found := selector.
		      selector := nil]
		 ifFalse:
		     [selector := selector next]].
    found == nil
	ifTrue:
	    [selector := aSelectorOrString is_selector
		 ifTrue:  [aSelectorOrString]
		 ifFalse: [self _value: aSelectorOrString _cString].
	     selector next: self list.
	     self list: selector]
	ifFalse:
	    [selector := found].
    ^selector
]

_selector _intern: _cString
[
    ^self intern: (_selector _value: _cString)
]


" ---------------------------------------------------------------- "
" Part 3 -- Dynamic binding (message lookup)                       "
" ---------------------------------------------------------------- "

" Looking up a selector in a vtbl.  Message sends always go through at
  least one level of method cache.  If the method is already in the
  cache then the send completes immediately.  Otherwise the runtime
  invokes this method in the vtbl of the receiver to find the method
  corresponding to the selector of the message being sent.  (Maybe it
  should invoke _lookup: on the receiver itself, for a chance to
  implement singleton behaviour?)  Answer the method corresponding to
  aSelector, or nil if the message is not understood.

  NOTE: The runtime enters the result of _every_ lookup in a method
  cache (hence user-level code might only have _one_ chance to
  influence the lookup for a given vtbl / selector combination, the
  first time that combination is seen).  There is currently no
  mechanism to prevent this eager cache filling, although there almost
  certainly should be one."

" Non-primitive version works fine, but causes a slight decrease in
  performance if any lines in the method cache are thrashing. "

"
_vtbl lookup: aSelector
[
    | found |
    found := nil.
    [self == nil]
        whileFalse:
            [| index last |
             index := 0.
	     last := self size.
	     [index < last and: [found == nil]]
		 whileTrue:
		     [| binding |
		      (binding := self bindingAt: index) selector == aSelector
	                  ifTrue: [found := binding _method].
		      index := index + 1].
	     self := found == nil ifTrue: [self delegate] ifFalse: [nil]].
    ^found
]
"

" Primitive version is about 30% faster for large programs containing
  polymorphic sends (e.g., the Compiler). "

_vtbl lookup: aSelector
{
  struct t__vtbl *this= (struct t__vtbl *)self;
  while (this)
    {
      struct t__binding **alist= (struct t__binding **)this->_bindings;
      int i, j= _integerValue(this->size);
      for (i= 0;  i < j;  ++i, ++alist)
	if (v_aSelector == (*alist)->selector)
	  return (*alist)->_method;
      this= (struct t__vtbl *)this->delegate;
    }
  return 0;
}


"----------------------------------------------------------------"

" Finally, flush the method caches to make sure the above definitions
  really are being used by the runtime. "

[ _vtbl flushCache ]


"================================================================"
"================================================================"

" Uncomment the following to see all of the above in action. "

"
_selector print		[ self name print ]
_selector println	[ self print.  '' println ]

_object _myDelegated
[
    self debugName print.  ': new prototype derived' println.
    ^self _basicDelegated
]

_object _myMethodAt: aSelector put: _aMethod
[
    '  method added: ' print.  self debugName print.  ' ' print.  aSelector println.
    ^self _basicMethodAt: aSelector put: _aMethod
]

_selector myIntern: aSelectorOrString
[
    'selector created: ' print.  aSelectorOrString println.
    ^self basicIntern: aSelectorOrString
]

_vtbl myLookup: aSelector
[
    'lookup: ' print.  aSelector println.
    ^self basicLookup: aSelector
]

_vtbl rename: oldName to: newName substituting: myName
[
    | old new my |
    old := _selector intern: oldName.
    new := _selector intern: newName.
    my  := _selector intern: myName.
    self
	at: new put: (self at: old);
	at: old put: (self at: my)
]

[
    _object   _vtbl rename: '_delegated'     to: '_basicDelegated'     substituting: '_myDelegated'.
    _object   _vtbl rename: '_methodAt:put:' to: '_basicMethodAt:put:' substituting: '_myMethodAt:put:'.
    _selector _vtbl rename: 'intern:'        to: 'basicIntern:'        substituting: 'myIntern:'.
    _vtbl     _vtbl rename: 'lookup:'        to: 'basicLookup:'        substituting: 'myLookup:'.

    _vtbl flushCache.
]
"