src/lib/segment.slate

   1 prototypes define: #Segment
   2     &slots:
   3       {#root. "The root object to trace from."
   4        #imports -> ExtensibleArray new. "The symbol table for the output."
   5        #relocations -> ExtensibleArray new. "The relocations for the output."
   6        #output -> ExtensibleArray new. "The output representations."
   7        #objects -> IdentityDictionary new. "Maps from object to it's particular represenation."}.
   8 "A Segment builds up a definition of a group of objects that can be extracted
   9 and serialized in binary form and then reloaded using a group of linking
  10 tables."
  11
  12 Segment traits define: #Representation
  13 "Object representation in the Segment's output."
  14   &slots:
  15     {#offset -> 0. "The allocated offset for the representation in the output."}.
  16
  17 Segment traits define: #Object &parents: {Segment Representation}
  18   &slots: {#map "The map which defines the structure.".
  19            #slotValues -> ExtensibleArray new "The values of various slots in the object."}.
  20
  21 rep@(Segment Object traits) new
  22 [rep clone `>> [slotValues := rep slotValues new. ]].
  23
  24 rep@(Segment Object traits) newFrom: obj
  25 [rep new `>> [slotValues addAllLast: obj slotValues. ]].
  26
  27 Segment traits define: #Array &parents: {Segment Object}
  28   &slots: {#elements -> ExtensibleArray new}.
  29
  30 a@(Segment Array traits) new
  31 [resend `>> [elements := a elements new. ]].
  32
  33 a@(Segment Array traits) newFrom: obj
  34 [resend `>> [elements addAllLast: obj. ]].
  35
  36 Segment traits define: #ByteArray &parents: {Segment Array}.
  37
  38 Segment traits define: #Method &parents: {Segment Representation}
  39   &slots: {#roles -> {} "Roles is a collection containing, for each argument position, an array of the objects upon which a role must be defined."}.
  40
  41 Segment Method traits define: #Primitive &parents: {Segment Method}
  42   &slots: {#index "The index in the primitive table of the repspective primitive"}.
  43
  44 rep@(Segment Method Primitive traits) newFrom: obj
  45 [rep clone `>> [selector := obj selector. index := obj index. ]].
  46
  47 Segment Method traits define: #Compiled &parents: {Segment Method}
  48   &slots: {#sourceCode "The source code which generated the particular compiled method."}.
  49
  50 rep@(Segment Method Compiled traits) newFrom: obj
  51 [
  52   rep clone `>>
  53     [selector := obj selector.
  54      roles := ((0 below: obj arity) collect: [| :_ | ExtensibleArray new]). ]
  55 ].
  56
  57 "TODO: Handle Closure objects."
  58
  59 Segment traits define: #Map &parents: {Segment Representation}
  60   &slots: {#delegates -> ExtensibleArray new.
  61            #slots -> {}}.
  62
  63 rep@(Segment Map traits) new
  64 [resend `>> [delegates := rep delegates new. slots := rep slots new. ]].
  65
  66 rep@(Segment Map traits) newFrom: obj
  67 [
  68   rep new `>>
  69    [| :newRep |
  70     (obj delegateNames with: obj delegates do:
  71       [| :slot :val | newRep delegates addLast: slot -> val]).
  72     rep slots := (Array newSize: obj slotCount).
  73     0 below: obj slotTable size by: 2 do:
  74       [| :index |
  75        (obj slotTable at: index)
  76          ifNotNilDo:
  77            [| :name offset |
  78             offset := (obj slotTable at: index + 1) >> 2 - 2.
  79             newRep slots at: offset put: name]]. ]
  80 ].
  81
  82 Segment traits define: #Import.
  83 "Imported values that must be evaluted when the image segment is loaded."
  84 [| :sym | Segment traits define: sym &parents: {Segment Import}]
  85   for: #{#Path. #Symbol}.
  86
  87 Segment traits define: #Relocation
  88 "Relocation against Imports"
  89     &slots:
  90       {#import. "The imported value this relocation takes as its value."
  91        #object. "The object being relocated against."
  92        #slot "The slot whose value needs to be relocated."}.
  93
  94 s@(Segment traits) newOn: root
  95 [
  96   s clone `>>
  97     [root := root.
  98      imports := s imports new.
  99      relocations := s relocations new.
 100      output := s output new.
 101      objects := s objects new. ]
 102 ].
 103
 104 s@(Segment traits) represents: obj
 105 "Whether the Segment has recorded a representation for the particular object."
 106 [s objects includesKey: obj].
 107
 108 s@(Segment traits) represent: obj as: rep
 109 "Ensures that the Segment has a representation of the object made from the given
 110 prototype."
 111 [s objects at: obj ifAbsentPut: [rep newFrom: obj]].
 112
 113 s@(Segment traits) trace: obj@(Root traits)
 114 "By default, trace objects as any standard thing with named slots, and then
 115 trace their map."
 116 [
 117   s represent: obj as: s Object.
 118   s trace: obj _map.
 119 ].
 120
 121 s@(Segment traits) trace: obj@(Array traits)
 122 [
 123   s represent: obj as: s Array.
 124   s trace: obj _map.
 125 ].
 126
 127 s@(Segment traits) trace: obj@(ByteArray traits)
 128 [
 129   s represent: obj as: s ByteArray.
 130   s trace: obj _map.
 131 ].
 132
 133 s@(Segment traits) trace: obj@(Map traits)
 134 [
 135   s represent: obj as: s Map.
 136 ].
 137
 138 s@(Segment traits) trace: obj@(PrimitiveMethod traits)
 139 [
 140   s represent: obj as: s Method Primitive.
 141 ].
 142
 143 s@(Segment traits) trace: obj@(CompiledMethod traits)
 144 [
 145   s represent: obj as: s Method Compiled.
 146 ].
 147
 148 s@(Segment traits) trace
 149 [s trace: s root].
 150
 151 s@(Segment traits) writeOn: out
 152 [
 153 ].
 154
 155 s@(Segment traits) readFrom: in
 156 [
 157 ].
 158
 159 s@(Segment traits) linkContents
 160 [
 161 ].
 162
 163 prototypes define: #SavedSegment &parents: {Segment}
 164   &slots: {#file -> File}.
 165
 166 s@(Segment traits) saveToFile: filename
 167 [
 168   (File newNamed: filename &mode: CreateWrite) sessionDo:
 169     [| :f | s writeOn: f writer]
 170 ].
 171
 172 s@(SavedSegment traits) saveToFile: filename
 173 [s file := (s file newNamed: filename)].
 174
 175 s@(Segment traits) loadFromFile: filename
 176 "Create a new SavedSegment for the file, and load and answer it."
 177 [SavedSegment clone `>> [| :ss | file := (ss file newNamed: filename). load. ]].
 178
 179 s@(SavedSegment traits) save
 180 "Write the segment into its file."
 181 [s file sessionDo: [| :f | s writeOn: f writer] &mode: s file Write].
 182
 183 s@(SavedSegment traits) load
 184 "(Re-)load the segment from its file."
 185 [s file sessionDo: [| :f | s readFrom: f reader] &mode: s file Read].