cloneSettingSlots: is broken

[Slom]

Hi all,

Yesterday I found some time looking into the bootstrap problems in 
'numeric.slate'. I think that the primitive cloneSettingSlots: is the culprit
 here, bc/ it doesnt handle delegate slots correctly. 

For comparison below are the original cloneSettingSlots: method when it was 
still defined in 'root.slate', the microcoded version and the primitive 
atSlotNamed:put: (slightly reformated, to fit in ~100 chars per line):

Note that the initial version of cloneSettingSlots: uses atSlotNamed:put: and
that the comment in the pigdin primitive indicates that the behaviour of 
cloneSettingSlots: should be the same as for atSlotNamed:put:. But the primitve
always puts the values into data-slots, even if the slot-entry is for an 
delegate!

What happens in 'numeric.slate' is the following: the define:... / derive:... 
eventually calls 

newObj: (d cloneSettingSlots: #(traitsWindow) to: {newWindow}).

with the intention to set the traitsWindow *delegate* of the new object to the
newly created traitsWindow. But the the primitive cloneSettingSlots: just puts
this new Window into a data slot, and leaves the delegate slot alone. Therefore
all the prototypes "derived" that way share exactly only one traitsWindow
delegate, which is the original traitsWindow of Cloneable. This explains why 
it seemed like the Comparable traitsWindow was modified. (storing the 
traitsWindow of Cloneable away before the define and comparing afterwards 
with == shows the explained behaviour clearly)  

Hope that helps, I have also added an untested new version of the 
cloneSettingSlots: method, basically merging the atSlotNamed:put:
code for handling delegates. Yesterday I hit a segfault after this change, 
so I'm not sure that this correct, but maybe we have moved a little :)

Regards,

Christian


***************** proposed cloneSettingSlots: primitive ***********************

obj at RootTraits cloneSettingSlots: slotArray at ArrayTraits to: 
valueArray at ArrayTraits
"Performs the act of cloning the object and taking arrays of slotNames and
values to set in matching order and performing the atSlotNamed:put: actions
to set up the new object - this is a convenience for creating instantiator
methods for immutable objects."
[| newObj!(Object pointer) map!(Map pointer) |
  obj isSmallInt
    ifTrue: [^ (interpreter stackPush: obj)].
  newObj: (CurrentMemory clone: obj pointer).
  map: newObj map.
  0 below: (slotArray pointer arraySize min: valueArray pointer arraySize)
    do: 
      [| :index name!ObjectPointer se!(SlotEntry pointer) |
        name: (slotArray pointer arrayElements at: index).
        se: (map slotTable hashEntryForName: name).
        se 
          ifNil: 
            [interpreter signal: SlotNotFoundSymbol with: obj with: name]
          ifNotNil:
            [| offset |
              offset: se offset asSmallInt.
              (offset bitAnd: SlotTypeMask) = SlotTypeData 
                ifTrue:
                  [ obj pointer slotValueAtOffset: (offset bitAnd: 
SlotOffsetMask)
                                              put: val]
                ifFalse:
                  [ map: (CurrentMemory clone: map).
                    map delegates: 
                      (CurrentMemory clone: map delegates)!(OopArray pointer) 
cast.
                    newObj changeMapTo: map. 
                    map delegates slotValueAtOffset: (offset bitAnd: 
SlotOffsetMask) 
                                                put: val]]].
  interpreter stackPush: newObj asObject
] `pidginPrimitive.

***************** cloneSettingSlots: for root.slate ***************************

x@(Root traits) cloneSettingSlots: slotsArray to: valuesArray
"Performs the act of cloning the object and taking arrays of slotNames and
values to set in matching order and performing the atSlotNamed:put: actions
to set up the new object - this is a convenience for creating instantiator
methods for immutable objects."
"TODO: Create a highly optimized version in the VM to replace this."
[| newX |
  newX: x clone.
  0 below: (slotsArray size min: valuesArray size) do:
    [| :index |
     newX atSlotNamed: (slotsArray at: index) put: (valuesArray at: index)].
  newX
].

***************** buggy cloneSettingSlots: primitive **************************

obj at RootTraits cloneSettingSlots: slotArray at ArrayTraits to: 
valueArray at ArrayTraits
"Performs the act of cloning the object and taking arrays of slotNames and
values to set in matching order and performing the atSlotNamed:put: actions
to set up the new object - this is a convenience for creating instantiator
methods for immutable objects."
[| newObj!(Object pointer) map!(Map pointer) |
  obj isSmallInt
    ifTrue: [^ (interpreter stackPush: obj)].
  newObj: (CurrentMemory clone: obj pointer).
  map: newObj map.
  0 below: (slotArray pointer arraySize min: valueArray pointer arraySize)
    do: [| :index name!ObjectPointer se!(SlotEntry pointer) |
     name: (slotArray pointer arrayElements at: index).
     se: (map slotTable hashEntryForName: name).
     se
       ifNil: [interpreter signal: SlotNotFoundSymbol with: obj with: name]
       ifNotNil:
         [newObj slotValueAtOffset: (se offset asSmallInt bitAnd: 
SlotOffsetMask) 
                               put: (valueArray pointer arrayElements at: 
index)]].
  interpreter stackPush: newObj asObject
] `pidginPrimitive.

***************** atSlotNamed:put: primitive **********************************

obj at RootTraits atSlotNamed: name at SymbolTraits put: val
[| map!(Map pointer) se!(SlotEntry pointer) |
  obj isSmallInt
    ifTrue: [^ (interpreter signal: SlotNotFoundSymbol with: obj with: name)].
  obj pointer isImmutable
    ifTrue: [^ (interpreter signal: ImmutableSymbol with: obj)].
  map: obj pointer map.
  se: (map slotTable hashEntryForName: name).
  se
    ifNil:
      [interpreter signal: SlotNotFoundSymbol with: obj with: name]
    ifNotNil:
      [| offset |
        offset: se offset asSmallInt.
        (offset bitAnd: SlotTypeMask) = SlotTypeData
          ifTrue:
            [interpreter stackPush: 
              (obj pointer slotValueAtOffset: (offset bitAnd: SlotOffsetMask) 
                                         put: val)]
          ifFalse:
            [| newMap!(Map pointer) |
              newMap: (CurrentMemory clone: map).
              newMap delegates: (CurrentMemory clone: newMap delegates)!
(OopArray pointer) cast.
              obj pointer changeMapTo: newMap.
              interpreter stackPush: 
                (newMap delegates slotValueAtOffset: (offset bitAnd: 
SlotOffsetMask) 
                                                put: val)]]
] `pidginPrimitive.