"GC-DUMP-DEFS"> %%> ;"to override GDECL in compiler" (OBJ) ANY (GCP NGCP) GC-PARAMS (NEW-SIZE BLOCK-LENGTH) FIX (PZN CZN NEW-ZONE) ZONE (HEADER) LIST (BLOCK) UVECTOR) "BINARY"> ,PURE-ZONE> ,PSIZE> ,PSIZE> ,M$$COPY-ON-WRITE>> >)>)> >> ;"calculate how large a zone we (could possibly) need" > > >)> <- >> >> 261632>>>)> ;"create the new zone" > >>> >>> > ;"WORDS-NEEDED counts how many words of memory might be needed by GC-READ when it reads in this object." ) ;"Provide DUMP-FRAME as an emergency exit" > %<>>> ;"whether dump succeeded or not, clean up" ,PSIZE> ,PSIZE> ,M$$READ-ONLY-EXECUTE>> >)>)> ;"if general error occured" ) (.FLAG ;"if he tried to dump something on the stack" ) (ELSE ;"winnage" > ;"dump one more object, the `header', a circular list of one element, the object dumped" > > <- ,ADDR-SHIFT>>> >> ;"create a uvector out of the dumped object" ;"write the data to the file" .OBJ)>) (ELSE )>> 7>) PTYP) #DECL ((X) ANY (FTYP) FIX (PTYP) ATOM) .X) (,STYPE-UVECTOR ) (,STYPE-STRING ) (,STYPE-BYTES ) (,STYPE-VECTOR ) (,STYPE-LIST ) (,STYPE-RECORD > ) (<==? .PTYP GBIND> ) (ELSE )>) DEFAULT ()>> -6>) TYP-ATM PTYP-ATM ENTRY) #DECL ((OBJ) ANY (TYP) FIX (ENTRY) TYPE-ENTRY (TYP-ATM PTYP-ATM) ATOM) ;"if the object is a newtype" >> >> ;"dump the atom naming the type (or get a pointer to it if it" ;"already has been dumped)" > ;"if the atom does not have a GVAL (which marks it as" ;"being the name of a newtype)" > > >> ;"then dump the atom naming the primtype" >> ;"and shove it (directly) into the GVAL slot")> T)>> ) FX NEW-V OLD-AL NEW-AL) ;"the classic case" #DECL ((V) (TOP-V NEW-V) VECTOR (FX NEW-AL OLD-AL) ) > ;"see if the object is marked" ;"if not" ;"take care of the object if it is a newtype" ;"remember where we now are in the zone" >> ;"mark the old vector to point to where the new vector will be" 2> 2> ,ADDR-SHIFT>>> ;"calculate where this will put us in the zone" ;"if we would run out of room, error" ) (ELSE ;"otherwise, make it official" )> 2> 2>> ;"actually copy the object" ;"unmark it (since we copied a marked object, this is" ;"necessary)" ;"dump the elements of the old vector and shove the" ;"results into the new vector" >>> .NEW-V>) (ELSE ;"if the object has already been dumped, return it" )> ;"return an object of the correct length and type" >> >> ) FX NEW-UV OLD-AL NEW-AL) #DECL ((UV) (TOP-UV NEW-UV) UVECTOR (FX) (NEW-AL OLD-AL) FIX) > >> 2> ,ADDR-SHIFT>>> ) (ELSE )> 2>> ) (ELSE )> >> >> (TOP-S NEW-S) STRING (FX) (WL NEW-AL OLD-AL) FIX) > > ,CHARS-WD-1> ,CHARS-WD> 2>> >> >> ) (ELSE )> .WL> ) (ELSE )> >> >> (TOP-BS NEW-BS) BYTES (FX) (WL NEW-AL OLD-AL) FIX) > > ,BYTES-WD-1> ,BYTES-WD> 2>> >> >> ) (ELSE )> .WL> ) (ELSE )> >> >> ;"Note that the code to dump (and unmark) lists is extremely hairy because lists don't have relocation fields, which we need, yet we cannot permenantly mung the old list. Solution: 1. Dump the list as usual. -------------------------- -------------------------- | rest of old list | | rest of new list | -------------------------- -------------------------- | type-c | length | | type-c | length | -------------------------- -------------------------- | pointer to old element | | pointer to new element | -------------------------- -------------------------- 2. Use the rest pointer of the old list as the relocation pointer (as is done in the copy-gc). However, store the old rest pointer (which will need to be restored) in the type-c and length slots of the new list. -------------------------- -------------------------- | pointer to new list | | rest of new list | -------------------------- -------------------------- | type-c | length | | rest of old list | -------------------------- -------------------------- | pointer to old element | | pointer to new element | -------------------------- -------------------------- 3. During the unmarking phase, copy the old rest pointer from the new list to the old list and copy the type-c and length from the new list to the old list. -------------------------- -------------------------- | rest of old list | | rest of new list | -------------------------- -------------------------- | type-c | length | | type-c | length | -------------------------- -------------------------- | pointer to old element | | pointer to new element | -------------------------- --------------------------" (NEW-L REST-L) LIST (OLD-AL NEW-AL) FIX) ) (<==? 0> > >> ) (ELSE )> > > > > > >>>>) (ELSE >)> >> (OLD-AL NEW-AL) FIX (FX) ) ROOT> ,LENUU-ATOM -1>>) (> FIX> > >> >> ) (ELSE )> > > ;"don't dump GVALs or LVALs" ;"Note: The gval slot IS used to store the primtypes of" ;"newtypes, but that is done by DUMP-NEWTYPE?" >> >>) (ELSE )> .NEW-ATM> (FX) (OLD-AL NEW-AL) FIX) > FIX> >> >> ) (ELSE )> >> > ;"don't dump the decl of gbinds") (ELSE )> .NGB> (PTYP) ATOM (FTYP) FIX) -6>) ENTRY) >> > >)>> 7>> ) (,STYPE-STRING ) (,STYPE-BYTES ) (,STYPE-VECTOR FIX>> ,UNMARK >)>) (,STYPE-LIST 0> > > >>> > > >> > >)>) (,STYPE-RECORD > FIX>> >> >>)>) (<==? .PTYP GBIND> FIX>> >>)>)>)> T> .MODE>)> )> >>>