"{ Package: 'cg:private' }"

Object subclass:#SnapShotImageMemory
	instanceVariableNames:'stream msb ptrSize intSize intTag spaceInfos symbolEntries
		globalEntries addrToObjectMapping'
	classVariableNames:''
	poolDictionaries:''
	category:'System-Support'
!

Object subclass:#SpaceInfo
	instanceVariableNames:'start end size flags imageBase'
	classVariableNames:''
	poolDictionaries:''
	privateIn:SnapShotImageMemory
!

Object variableSubclass:#ImageObject
	instanceVariableNames:'classRef size bits'
	classVariableNames:''
	poolDictionaries:''
	privateIn:SnapShotImageMemory
!

SnapShotImageMemory::ImageObject variableSubclass:#ImageClassObject
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:SnapShotImageMemory
!


!SnapShotImageMemory class methodsFor:'instance creation'!

for:aFilename
    ^ self new for:aFilename
! !

!SnapShotImageMemory class methodsFor:'private'!

isNilOOP:anOOP
    ^ anOOP == 0
!

isPointerOOP:anOOP
    ^ (anOOP bitTest:1) not
!

isSmallIntegerOOP:anOOP
    ^ anOOP bitTest:1
! !

!SnapShotImageMemory methodsFor:'accessing'!

globalEntries
    "return the value of the instance variable 'globalEntries' (automatically generated)"

    ^ globalEntries!

globalEntries:something
    "set the value of the instance variable 'globalEntries' (automatically generated)"

    globalEntries := something.! !

!SnapShotImageMemory methodsFor:'object access'!

fetchClassObjectAt:baseAddr
    |addr classPtr size bits o|

    o := addrToObjectMapping at:baseAddr ifAbsent:nil.
    o notNil ifTrue:[^ o].

    addr := baseAddr.
    classPtr := self fetchPointerAt:addr.
    addr := addr + ptrSize.
    size := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.
    bits := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.

    o := ImageClassObject new:(size - intSize - intSize - intSize).
    o classRef:classPtr.
    o size:size.
    o bits:bits.

    1 to:size // intSize do:[:idx |
        o at:idx put:(self fetchUnboxedIntegerAt:addr).
        addr := addr + 1.
    ].

    addrToObjectMapping at:baseAddr put:o.
    ^ o
!

fetchObjectAt:baseAddr
    |addr classPtr classRef size bits o|

    o := addrToObjectMapping at:baseAddr ifAbsent:nil.
    o notNil ifTrue:[^ o].

    addr := baseAddr.
    classPtr := self fetchPointerAt:addr.
    addr := addr + ptrSize.
    size := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.
    bits := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.

    (self class isPointerOOP:classPtr) ifFalse:[
        self halt
    ].

    classRef := self fetchClassObjectAt:classPtr.
    classRef isImageBehavior ifFalse:[
        self halt.
    ].

    o := ImageObject new:(size - intSize - intSize - intSize).
    o classRef:classRef.
    o size:size.
    o bits:bits.

    self halt.
!

fetchObjectHeaderAt:baseAddr
    |addr class size bits|

    addr := baseAddr.
    class := self fetchPointerAt:addr.
    addr := addr + ptrSize.
    size := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.
    bits := self fetchUnboxedIntegerAt:addr.
    addr := addr + ptrSize.

    self halt.
!

fetchPointerAt:addr
    ^ self fetchUnboxedIntegerAt:addr
!

fetchUnboxedIntegerAt:addr
    spaceInfos do:[:eachSpace |
        |ptr imgAddr|

        addr >= eachSpace start ifTrue:[
            addr <= eachSpace end ifTrue:[
                imgAddr := eachSpace imageBase + (addr - eachSpace start).
                stream position:imgAddr.
                ptr := stream nextUnsignedLongMSB:msb.
                ^ ptr
            ]
        ].
    ].
    self halt:'image fetch error'.
! !

!SnapShotImageMemory methodsFor:'private'!

allClassesDo:aBlock
    self allGlobalKeysDo:[:eachKey |
        |val|

        val := self at:eachKey.
        val isBehavior ifTrue:[
            aBlock value:val
        ]
    ].
!

allGlobalKeysDo:aBlock
    globals isNil ifTrue:[
        self readHeader.
        self readGlobals.
    ].
!

for:aFilename
    stream := aFilename asFilename readStream binary.
    addrToObjectMapping := IdentityDictionary new.
!

readGlobalEntries
        |refPointer theSymbol theValue|

        globalEntries := OrderedCollection new.
        [
            refPointer := stream nextUnsignedLongMSB:msb.
            theSymbol := stream nextUnsignedLongMSB:msb.
            theValue := stream nextUnsignedLongMSB:msb.
            theSymbol ~~ 0
        ] whileTrue:[
            globalEntries add:(theSymbol -> theValue).
        ].
        globalEntries := globalEntries asArray
!

readHeader
        "
         (self for:'stmeas.img') readHeader
        "

        |order magic version timeStamp snapID last_util_addr hiText_addr flags 
         lowData hiData charSlots charTableSlots fixMemStart fixMemEnd 
         symMemStart symMemEnd vmDataAddr sharedMethodCode sharedBlockCode 
         nContexts contextSpace nRegistered symbolsSeqNr nSpaces 
         spaceFlags spaceBase spaceSize classNameSize|

        stream next:256.        "/ skip execCmd

        msb := false.
        order := stream nextUnsignedLongMSB:msb.        
        order = 16r076543210 ifTrue:[
        ] ifFalse:[
            order = 16r01234567 ifTrue:[
                msb := true.
            ] ifFalse:[
                self error:'unhandled byteorder'
            ].
        ].
        magic := (stream next:8) asString.
        magic ~= 'ST/X-IMG' ifTrue:[
            self error:'not an st/x image'
        ].
        version := stream nextUnsignedLongMSB:msb.        
        timeStamp := stream nextUnsignedLongMSB:msb.        
        ptrSize := stream nextByte.        
        ptrSize ~~ 4 ifTrue:[
            self error:'unhandled ptr format'
        ].
        stream next:7.    "/ filler    
        intSize := stream nextUnsignedLongMSB:msb.        
        intSize == 9 ifTrue:[
            intSize := 4.
            intTag := 1.
        ] ifFalse:[
            self error:'unhandled int format'
        ].
        
        snapID := stream nextUnsignedLongMSB:msb.        
        last_util_addr := stream next:intSize.        
        hiText_addr := stream next:intSize.        
        flags := stream next:intSize.        
        stream next:8.    "/ info, debug & filler    

        lowData := stream nextUnsignedLongMSB:msb.
        hiData := stream nextUnsignedLongMSB:msb.

        charSlots := stream nextUnsignedLongMSB:msb.
        charTableSlots := stream nextUnsignedLongMSB:msb.

        version >= 8 ifTrue:[
            fixMemStart := stream nextUnsignedLongMSB:msb.
            fixMemEnd := stream nextUnsignedLongMSB:msb.
            symMemStart := stream nextUnsignedLongMSB:msb.
            symMemEnd := stream nextUnsignedLongMSB:msb.
            vmDataAddr := stream nextUnsignedLongMSB:msb.
        ].
        stream next:(128 * intSize).    "/ skip sharedMethodCode ptrs
        stream next:(128 * intSize).    "/ skip sharedBlockCode ptrs

        nContexts := stream nextUnsignedLongMSB:msb.
        contextSpace := stream nextUnsignedLongMSB:msb.
        nRegistered := stream nextUnsignedLongMSB:msb.

        version >= 8 ifTrue:[
            version >= 9 ifTrue:[
                symbolsSeqNr := stream nextUnsignedLongMSB:msb.
                stream next:(intSize * 31).
            ] ifFalse:[
                stream next:(intSize * 32).
            ]
        ].

        nSpaces := stream nextUnsignedLongMSB:msb.
        spaceInfos := (1 to:nSpaces) collect:[:idx | SpaceInfo new].
        
        spaceBase := Array new:nSpaces.
        spaceSize := Array new:nSpaces.
        1 to:nSpaces do:[:i |
            (spaceInfos at:i) flags:(stream nextUnsignedLongMSB:msb).
        ].
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].

        1 to:nSpaces do:[:i |
            (spaceInfos at:i) start:(stream nextUnsignedLongMSB:msb).
        ].
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].

        1 to:nSpaces do:[:i |
            (spaceInfos at:i) size:(stream nextUnsignedLongMSB:msb).
        ].
        nSpaces+1 to:32 do:[:i | stream nextUnsignedLongMSB:msb].

        version >= 8 ifTrue:[
            stream position:(stream class zeroPosition + 4096).
        ].

        1 to:nSpaces do:[:i |
            (spaceInfos at:i) end:((spaceInfos at:i) start + (spaceInfos at:i) size - 1).
        ].
        1 to:nSpaces do:[:i |
            (spaceInfos at:i) imageBase:(stream position).
            stream skip:((spaceInfos at:i) size).
        ].

        "/ registration

        self readRegistrationEntries.
        self readSymbolEntries.
        self readGlobalEntries.
        self readUGlobalEntries.


"/struct basicImageHeader {
"/        char            h_execCmd[256];
"/
"/        int             h_orderWord;
"/        char            h_magic[8];
"/        int             h_version;
"/        int             h_timeStamp;
"/        char            h_ptrSize;
"/        char            h_filler1[7];
"/        int             h_intSize;
"/        int             h_snapID;
"/        INT             h_last_util_addr;
"/        INT             h_hiText_addr;
"/        INT             h_flags;
"/        char            h_infoPrinting;
"/        char            h_debugPrinting;
"/        char            h_filler2[6];
"/
"/        /*
"/         * these are to verify compatibility of the image with
"/         * myself ...
"/         * this is now obsolete.
"/         */
"/        INT             h_lowData, h_hiData;
"/
"/        /*
"/         * base address of character- and characterTable slots
"/         */
"/        INT             h_charSlots;
"/        INT             h_charTableSlots;
"/
"/#if HEADER_VERSION >= 8
"/        /*
"/         * the fixBase (VMDATA address)
"/         */
"/        INT             h_fixMemStart;
"/        INT             h_fixMemEnd;
"/        INT             h_symMemStart;
"/        INT             h_symMemEnd;
"/
"/        INT             h_vmDataAddr;
"/#endif
"/
"/        INT             h_sharedMethodCode[128];
"/        INT             h_sharedBlockCode[128];
"/
"/        /*      
"/         * space needed to restore contexts
"/         */
"/        INT             h_nContexts;
"/        INT             h_contextSpace;
"/
"/        /*
"/         * number of class registration info records
"/         */
"/        INT             h_nRegistered;
"/
"/#if HEADER_VERSION >= 8
"/        /*
"/         * reserved slots, for future versions
"/         * (can add additional info, without affecting position of following stuff)
"/         * If you add slots, you MUST DECREMENT the fillcount.
"/         */
"/# if HEADER_VERSION >= 9
"/        INT             h_symbolsSeqNr;
"/        INT             h_reserved[31];
"/# else
"/        INT             h_reserved[32];
"/# endif
"/#endif
"/
"/        /*
"/         * number of spaces, base and size of each
"/         */
"/        INT             h_nSpaces;
"/        INT             h_spaceFlags[MAXSPACES];
"/        INT             h_spaceBase[MAXSPACES];
"/        INT             h_spaceSize[MAXSPACES];
"/
"/        /*
"/         * here come nSpaces object spaces
"/         */
"/
"/        /*
"/         * here comes registration info
"/         */
"/
"/        /*
"/         * here come nSymbols symbolEntries
"/         * followed by a zero/zero entry
"/         */
"/
"/        /*
"/         * here come nGlobal globalEntries
"/         * followed by a zero/zero entry
"/         */
"/
"/        /*
"/         * here come nUnnamedGlobal globalEntries
"/         * followed by a zero/zero entry
"/         */
"/
"/        /*
"/         * here come stack contexts
"/         */
"/};      
!

readRegistrationEntries
        |classNameSize|

        [
            classNameSize := stream nextUnsignedLongMSB:msb.
            classNameSize ~~ 0
        ] whileTrue:[
            |className flags moduleTimestamp signature nMethods nBlocks oldLitRefs nLitRefs
             oldConstTable nConsts|

            className := (stream next:classNameSize) asString.
            stream next. "/ 0-byte
            flags := stream nextUnsignedLongMSB:msb.
            moduleTimestamp := stream nextUnsignedLongMSB:msb.   
            signature := stream nextUnsignedLongMSB:msb.   
            nMethods := stream nextUnsignedLongMSB:msb.   
            nMethods timesRepeat:[ stream nextUnsignedLongMSB:msb ].
            nBlocks := stream nextUnsignedLongMSB:msb.   
            nBlocks timesRepeat:[ stream nextUnsignedLongMSB:msb ].
            oldLitRefs := stream nextUnsignedLongMSB:msb.  
            nLitRefs := stream nextUnsignedLongMSB:msb.
            nLitRefs timesRepeat:[ stream nextUnsignedLongMSB:msb ].
            stream nextUnsignedLongMSB:msb. "/ 0-litRef
            oldConstTable := stream nextUnsignedLongMSB:msb.  
            nConsts := stream nextUnsignedLongMSB:msb.
            nConsts timesRepeat:[ stream nextUnsignedLongMSB:msb ].

            Transcript showCR:className.
        ].
!

readSymbolEntries
        |refPointer theSymbol|

        symbolEntries := OrderedCollection new.

        [
            refPointer := stream nextUnsignedLongMSB:msb.
            theSymbol := stream nextUnsignedLongMSB:msb.
        
            theSymbol ~~ 0
        ] whileTrue:[
            symbolEntries add:(theSymbol -> refPointer).
        ].
        symbolEntries := symbolEntries asArray
!

readUGlobalEntries
        |refPointer theValue|

        [
            refPointer := stream nextUnsignedLongMSB:msb.
            theValue := stream nextUnsignedLongMSB:msb.
            refPointer ~~ 0
        ] whileTrue
! !

!SnapShotImageMemory::SpaceInfo methodsFor:'accessing'!

end
    "return the value of the instance variable 'end' (automatically generated)"

    ^ end!

end:something
    "set the value of the instance variable 'end' (automatically generated)"

    end := something.!

flags
    "return the value of the instance variable 'flags' (automatically generated)"

    ^ flags!

flags:something
    "set the value of the instance variable 'flags' (automatically generated)"

    flags := something.!

imageBase
    "return the value of the instance variable 'imageBase' (automatically generated)"

    ^ imageBase!

imageBase:something
    "set the value of the instance variable 'imageBase' (automatically generated)"

    imageBase := something.!

size
    "return the value of the instance variable 'size' (automatically generated)"

    ^ size!

size:something
    "set the value of the instance variable 'size' (automatically generated)"

    size := something.!

start
    "return the value of the instance variable 'start' (automatically generated)"

    ^ start!

start:something
    "set the value of the instance variable 'start' (automatically generated)"

    start := something.! !

!SnapShotImageMemory::ImageObject methodsFor:'accessing'!

bits
    "return the value of the instance variable 'bits' (automatically generated)"

    ^ bits!

bits:something
    "set the value of the instance variable 'bits' (automatically generated)"

    bits := something.!

classRef
    "return the value of the instance variable 'classRef' (automatically generated)"

    ^ classRef!

classRef:something
    "set the value of the instance variable 'classRef' (automatically generated)"

    classRef := something.!

size
    "return the value of the instance variable 'size' (automatically generated)"

    ^ size!

size:something
    "set the value of the instance variable 'size' (automatically generated)"

    size := something.! !

!SnapShotImageMemory::ImageObject methodsFor:'queries'!

isImageBehavior
    |flags|

    flags := self flagsSlot.

    (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
        self halt
    ].
    flags := flags bitShift:-1.
    ^ flags bitTest:Behavior flagBehavior  
!

isImageBytes
    self halt.
!

isImageString
    self halt.
!

isImageSymbol
    self halt.
! !

!SnapShotImageMemory::ImageClassObject methodsFor:'accessing - slots'!

categorySlot
    ^ self at:8
!

classFilenameSlot
    ^ self at:12
!

classVarsSlot
    ^ self at:9
!

commentSlot
    ^ self at:10
!

flagsSlot
    ^ self at:2
!

flagsValue
    |flags|

    flags := self flagsSlot.

    (SnapShotImageMemory isSmallIntegerOOP:flags) ifFalse:[
        self halt
    ].
    ^ flags bitShift:-1.
!

instSizeSlot
    ^ self at:5
!

instVarsSlot
    ^ self at:6
!

methodDictionarySlot
    ^ self at:3
!

nameSlot
    ^ self at:7
!

packageSlot
    ^ self at:13
!

revisionSlot
    ^ self at:14
!

superClassSlot
    ^ self at:1
! !

!SnapShotImageMemory class methodsFor:'documentation'!

version
    ^ '$Header$'
! !