hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fixed a GC bug caused by a temporary object pointer pointing to the symbol table

Browse Source
This commit is contained in:
hyung-hwan 2014-01-17 13:03:05 +00:00
parent a4e4c5c127
commit d1af233db4
3 changed files with 115 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
lib/h2-scheme-execute.adb
View File

@ -188,13 +188,11 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if; end if;
declare declare
Closure: aliased Object_Pointer; Closure: Object_Pointer;
begin begin
Push_Top (Interp, Closure'Unchecked_Access); -- not necessary
Closure := Make_Closure (Interp.Self, Operand, Interp.Environment); Closure := Make_Closure (Interp.Self, Operand, Interp.Environment);
Pop_Frame (Interp); -- Done Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure); Chain_Frame_Result (Interp, Interp.Stack, Closure);
Pop_Tops (Interp, 1); -- not necessary
end; end;
end if; end if;
@ -389,7 +387,6 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
-- Push a new environmen for the closure -- Push a new environmen for the closure
Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func)); Interp.Environment := Make_Environment (Interp.Self, Get_Closure_Environment(Func));
-- TODO: GC. Func may be invalid if GC has been invoked.
Fbody := Get_Closure_Code(Func); Fbody := Get_Closure_Code(Func);
pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this. pragma Assert (Is_Cons(Fbody)); -- the reader must ensure this.
@ -430,8 +427,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
raise Syntax_Error; raise Syntax_Error;
end if; end if;
-- TODO: GC. the environment construction can cause GC. so Fbody here may be invalid. -- TODO: is it correct to keep the environement in the frame?
-- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Fbody); Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
@ -456,10 +452,6 @@ Print (Interp, Operand);
Args := Get_Cdr(Operand); Args := Get_Cdr(Operand);
-- No GC must be performed here.
-- Otherwise, Operand, Func, Args get invalidated
-- since GC doesn't update local variables.
case Func.Tag is case Func.Tag is
when Procedure_Object => when Procedure_Object =>
case Get_Procedure_Opcode(Func) is case Get_Procedure_Opcode(Func) is
@ -700,7 +692,7 @@ Print (Interp, Operand);
end Fetch_Token; end Fetch_Token;
procedure Read_List is procedure Read_List is
--pragma Inline (Read_List); pragma Inline (Read_List);
V: aliased Object_Pointer; V: aliased Object_Pointer;
begin begin
-- This procedure reads each token in a list. -- This procedure reads each token in a list.
@ -710,7 +702,7 @@ Print (Interp, Operand);
Fetch_Token; Fetch_Token;
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is case Interp.Token.Kind is
when End_Token => when End_Token =>
@ -751,18 +743,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
Print_Object_Pointer ("000 Identifier => Stack => ", Interp.Stack);
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
Print_Object_Pointer ("111 Identifier => Stack => ", Interp.Stack);
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack);
when others => when others =>
-- TODO: set various error info -- TODO: set various error info
raise Syntax_Error; raise Syntax_Error;
end case; end case;
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Read_List; end Read_List;
procedure Read_List_Cdr is procedure Read_List_Cdr is
@ -776,7 +765,7 @@ Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack);
-- to handle the head item specially. -- to handle the head item specially.
Fetch_Token; Fetch_Token;
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is case Interp.Token.Kind is
when End_Token => when End_Token =>
@ -801,13 +790,11 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
when String_Token => when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware
Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
@ -816,7 +803,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
raise Syntax_Error; raise Syntax_Error;
end case; end case;
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Read_List_Cdr; end Read_List_Cdr;
procedure Read_List_End is procedure Read_List_End is
@ -825,42 +812,42 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
begin begin
Fetch_Token; Fetch_Token;
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is case Interp.Token.Kind is
when Right_Parenthesis_Token => when Right_Parenthesis_Token =>
V := Get_Frame_Result(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
pragma Assert (V /= Nil_Pointer); pragma Assert (V /= Nil_Pointer);
-- The first item in the chain is actually Cdr of the last cell. -- The first item in the chain is actually Cdr of the last cell.
V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); -- TODO: GC V := Reverse_Cons(Get_Cdr(V), Get_Car(V));
Pop_Frame (Interp); Pop_Frame (Interp);
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when others => when others =>
raise Syntax_Error; raise Syntax_Error;
end case; end case;
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Read_List_End; end Read_List_End;
procedure Close_List is procedure Close_List is
pragma Inline (Close_List); pragma Inline (Close_List);
V: aliased Object_Pointer; V: aliased Object_Pointer;
begin begin
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
V := Get_Frame_Result(Interp.Stack); V := Get_Frame_Result(Interp.Stack);
pragma Assert (Get_Cdr(V) = Nil_Pointer); pragma Assert (Get_Cdr(V) = Nil_Pointer);
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V)); Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V));
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Close_List; end Close_List;
procedure Close_Quote is procedure Close_Quote is
pragma Inline (Close_Quote); pragma Inline (Close_Quote);
V: aliased Object_Pointer; V: aliased Object_Pointer;
begin begin
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
-- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote") -- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote")
Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote)); Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote));
@ -868,7 +855,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Close_Quote; end Close_Quote;
procedure Read_Object is procedure Read_Object is
@ -877,7 +864,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
begin begin
Fetch_Token; Fetch_Token;
Push_Top (Interp, V'Unchecked_Access); --Push_Top (Interp, V'Unchecked_Access);
case Interp.Token.Kind is case Interp.Token.Kind is
when End_Token => when End_Token =>
@ -900,13 +887,11 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
when String_Token => when String_Token =>
V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
when Identifier_Token => when Identifier_Token =>
V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
-- TODO: make V gc-aware
Pop_Frame (Interp); -- Done with the current frame Pop_Frame (Interp); -- Done with the current frame
Chain_Frame_Result (Interp, Interp.Stack, V); Chain_Frame_Result (Interp, Interp.Stack, V);
@ -915,7 +900,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
raise Syntax_Error; raise Syntax_Error;
end case; end case;
Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
end Read_Object; end Read_Object;
begin begin
@ -986,27 +971,6 @@ begin
pragma Assert (Interp.Top.Last < Interp.Top.Data'First); pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
loop loop
--if Is_Normal_Pointer(Interp.Stack) then
--declare
-- X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
-- type XX is access all object_pointer;
-- t: xx := Interp.Stack'Unchecked_access;
-- w: object_word;
-- for w'address use t'address;
--
-- ww: object_word;
-- for ww'address use interp.stack'address;
--
-- www: object_word;
-- for www'address use interp.stack'address;
--begin
-- Ada.Text_IO.Put_Line ("$$$$$ [XXXXX] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " &object_word'image(w) & " VALUE: " & object_word'image(ww) & " VALUE2: " & object_word'image(www));
-- Print_Object_Pointer (" ====> t", t.all);
--end;
--Print_Object_Pointer (" ====> Stack", Interp.Stack);
--end if;
case Get_Frame_Opcode(Interp.Stack) is case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit => when Opcode_Exit =>
exit; exit;
@ -1047,9 +1011,6 @@ begin
end case; end case;
end loop; end loop;
-- the stack must be empty when the loop is terminated
--pragma Assert (Interp.Stack = Nil_Pointer);
exception exception
when Stream_End_Error => when Stream_End_Error =>
raise; raise;

234
lib/h2-scheme.adb
View File

@ -325,7 +325,10 @@ package body H2.Scheme is
Output_Character_Array (Source.Character_Slot); Output_Character_Array (Source.Character_Slot);
end if; end if;
else else
Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) & " kind: " & Object_Kind'Image(Source.Kind) & " size: " & Object_Size'Image(Source.Size)); Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) &
" kind: " & Object_Kind'Image(Source.Kind) &
" size: " & Object_Size'Image(Source.Size) &
" tag: " & Object_Tag'Image(Source.Tag));
end if; end if;
end Print_Object_Pointer; end Print_Object_Pointer;
@ -422,6 +425,17 @@ package body H2.Scheme is
return Object.New_Pointer; return Object.New_Pointer;
end Get_New_Location; end Get_New_Location;
function Verify_Pointer (Source: in Object_Pointer) return Object_Pointer is
pragma Inline (Verify_Pointer);
begin
if not Is_Normal_Pointer(Source) or else
Source.Kind /= Moved_Object then
return Source;
else
return Get_New_Location(Source);
end if;
end Verify_Pointer;
function Allocate_Bytes_In_Heap (Heap: access Heap_Record; function Allocate_Bytes_In_Heap (Heap: access Heap_Record;
Heap_Bytes: in Heap_Size) return Heap_Element_Pointer is Heap_Bytes: in Heap_Size) return Heap_Element_Pointer is
Avail: Heap_Size; Avail: Heap_Size;
@ -436,7 +450,6 @@ package body H2.Scheme is
Avail := Heap.Size - Heap.Bound; Avail := Heap.Size - Heap.Bound;
if Real_Bytes > Avail then if Real_Bytes > Avail then
Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap_Size'Image(Real_Bytes));
return null; return null;
end if; end if;
@ -467,6 +480,11 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
return 1; return 1;
end if; end if;
if Source = Nil_Pointer then
ada.text_io.put_line ("HEAP SOURCE IS NIL");
return 0;
end if;
raise Internal_Error; raise Internal_Error;
end Get_Heap_Number; end Get_Heap_Number;
@ -514,6 +532,7 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
Last_Pos: Heap_Size; Last_Pos: Heap_Size;
New_Heap: Heap_Number; New_Heap: Heap_Number;
Original_Symbol_Table: Object_Pointer;
--function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer); --function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
@ -627,6 +646,8 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
procedure Compact_Symbol_Table is procedure Compact_Symbol_Table is
Pred: Object_Pointer; Pred: Object_Pointer;
Cons: Object_Pointer; Cons: Object_Pointer;
Car: Object_Pointer;
Cdr: Object_Pointer;
begin begin
-- TODO: Change code here if the symbol table structure is changed to a hash table. -- TODO: Change code here if the symbol table structure is changed to a hash table.
@ -635,78 +656,66 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap
while Cons /= Nil_Pointer loop while Cons /= Nil_Pointer loop
pragma Assert (Cons.Tag = Cons_Object); pragma Assert (Cons.Tag = Cons_Object);
declare Car := Cons.Pointer_Slot(Cons_Car_Index);
Car: Object_Pointer renames Cons.Pointer_Slot(Cons_Car_Index); Cdr := Cons.Pointer_Slot(Cons_Cdr_Index);
Cdr: Object_Pointer renames Cons.Pointer_Slot(Cons_Cdr_Index); pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object);
begin
pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object);
if Car.Kind /= Moved_Object and then if Car.Kind /= Moved_Object and then
(Car.Flags and Syntax_Object) = 0 then (Car.Flags and Syntax_Object) = 0 then
-- A non-syntax symbol has not been moved. -- A non-syntax symbol has not been moved.
-- Unlink the cons cell from the symbol table. -- Unlink the cons cell from the symbol table.
if Pred = Nil_Pointer then
--Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & Character_Array_To_String (Car.Character_Slot)); Interp.Symbol_Table := Cdr;
if Pred = Nil_Pointer then else
Interp.Symbol_Table := Cdr; Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr;
else
Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr;
end if;
end if; end if;
else
Cons := Cdr; Pred := Cons;
end; end if;
Cons := Cdr;
end loop; end loop;
end Compact_Symbol_Table; end Compact_Symbol_Table;
begin begin
declare --declare
Avail: Heap_Size; --Avail: Heap_Size;
begin --begin
Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound; --Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
Ada.Text_IO.Put_Line (">>> [GC BEGIN] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail)); --Ada.Text_IO.Put_Line (">>> [GC BEGIN] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
end; --end;
-- As the Heap_Number type is a modular type that can -- As the Heap_Number type is a modular type that can
-- represent 0 and 1, incrementing it gives the next value. -- represent 0 and 1, incrementing it gives the next value.
New_Heap := Interp.Current_Heap + 1; New_Heap := Interp.Current_Heap + 1;
-- Migrate some root objects -- Migrate some root objects
Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark); --Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark);
Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack); --Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack);
if Is_Normal_Pointer(Interp.Stack) then if Is_Normal_Pointer(Interp.Stack) then
Interp.Stack := Move_One_Object(Interp.Stack); Interp.Stack := Move_One_Object(Interp.Stack);
Interp.Stack_XXX := Interp.Stack;
declare
X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
type XX is access all object_pointer;
t: xx := Interp.Stack'Unchecked_access;
w: object_word;
for w'address use t'address;
begin
Ada.Text_IO.Put_Line (">>> [GC MOVE] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " & Object_word'Image(w));
end;
end if; end if;
Print_Object_Pointer (">>> [GC] Stack AFTER ...", Interp.Stack);
Interp.Root_Environment := Move_One_Object(Interp.Root_Environment); Interp.Root_Environment := Move_One_Object(Interp.Root_Environment);
Interp.Environment := Move_One_Object(Interp.Environment); Interp.Environment := Move_One_Object(Interp.Environment);
Interp.Mark := Move_One_Object(Interp.Mark); Interp.Mark := Move_One_Object(Interp.Mark);
-- Migrate temporary object pointers -- Migrate temporary object pointers
ADa.TEXT_IO.PUT_LINE (">>> [GC] TOP BEGIN: " & Interp.Top.Data'First'Img & ":" & Interp.Top.Last'Img);
for I in Interp.Top.Data'First .. Interp.Top.Last loop for I in Interp.Top.Data'First .. Interp.Top.Last loop
if Interp.Top.Data(I).all /= null and then if Interp.Top.Data(I).all = Interp.Symbol_Table then
Is_Normal_Pointer(Interp.Top.Data(I).all) then -- The symbol table must stay before compaction.
-- Skip migrating a temporary object pointer if it
-- is pointing to the symbol table. Remember that
-- such skipping has happened.
Original_Symbol_Table := Interp.Symbol_Table;
elsif Interp.Top.Data(I).all /= null and then
Is_Normal_Pointer(Interp.Top.Data(I).all) then
Interp.Top.Data(I).all := Move_One_Object(Interp.Top.Data(I).all); Interp.Top.Data(I).all := Move_One_Object(Interp.Top.Data(I).all);
end if; end if;
end loop; end loop;
ADa.TEXT_IO.PUT_LINE (">>> [GC] TOP END");
Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]"); --Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
-- Scan the heap -- Scan the heap
Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First); Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);
@ -714,14 +723,24 @@ Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
-- If the symbol has not moved to the new heap, the symbol -- If the symbol has not moved to the new heap, the symbol
-- is not referenced by any other objects than the symbol -- is not referenced by any other objects than the symbol
-- table itself -- table itself
Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]"); --Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]");
Compact_Symbol_Table; Compact_Symbol_Table;
Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table); --Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
-- Migrate the symbol table itself -- Migrate the symbol table itself
Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table); Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]"); -- Update temporary object pointers that were pointing to the symbol table
if Original_Symbol_Table /= null then
for I in Interp.Top.Data'First .. Interp.Top.Last loop
if Interp.Top.Data(I).all = Original_Symbol_Table then
-- update to the new symbol table
Interp.Top.Data(I).all := Interp.Symbol_Table;
end if;
end loop;
end if;
--Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]");
-- Scan the new heap again from the end position of -- Scan the new heap again from the end position of
-- the previous scan to move referenced objects by -- the previous scan to move referenced objects by
-- the symbol table. -- the symbol table.
@ -730,25 +749,14 @@ Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]
-- Swap the current heap and the new heap -- Swap the current heap and the new heap
Interp.Heap(Interp.Current_Heap).Bound := 0; Interp.Heap(Interp.Current_Heap).Bound := 0;
Interp.Current_Heap := New_Heap; Interp.Current_Heap := New_Heap;
declare --declare
Avail: Heap_Size; --Avail: Heap_Size;
begin --begin
Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound; --Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack); --Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack);
if Is_Normal_Pointer(Interp.Stack) then --Ada.Text_IO.Put_Line (">>> [GC DONE] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
declare --Ada.Text_IO.Put_Line (">>> [GC DONE] ----------------------------------------------------------");
X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack); --end;
type XX is access all object_pointer;
t: xx := Interp.Stack'Unchecked_access;
w: object_word;
for w'address use t'address;
begin
Ada.Text_IO.Put_Line (">>> [GC DONE] Stack in HEAP: " & Heap_Number'Image(X) & " FROM: " & Object_word'Image(w));
end;
end if;
Ada.Text_IO.Put_Line (">>> [GC DONE] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
Ada.Text_IO.Put_Line (">>> [GC DONE] ----------------------------------------------------------");
end;
end Collect_Garbage; end Collect_Garbage;
function Allocate_Bytes (Interp: access Interpreter_Record; function Allocate_Bytes (Interp: access Interpreter_Record;
@ -881,28 +889,12 @@ end if;
return Result; return Result;
end Allocate_Byte_Object; end Allocate_Byte_Object;
function Verify_Pointer (Source: in Object_Pointer) return Object_Pointer is
pragma Inline (Verify_Pointer);
begin
if not Is_Normal_Pointer(Source) or else
Source.Kind /= Moved_Object then
return Source;
else
return Get_New_Location(Source);
end if;
end Verify_Pointer;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
procedure Push_Top (Interp: in out Interpreter_Record; procedure Push_Top (Interp: in out Interpreter_Record;
Source: access Object_Pointer) is Source: access Object_Pointer) is
Top: Top_Record renames Interp.Top; Top: Top_Record renames Interp.Top;
begin begin
--declare
-- W: Object_WOrd;
-- for W'address use Source'address;
--begin
--Ada.Text_IO.Put_Line ("Push_Top - " & Object_WOrd'Image(W));
--end;
if Top.Last >= Top.Data'Last then if Top.Last >= Top.Data'Last then
-- Something is wrong. Too many temporary object pointers -- Something is wrong. Too many temporary object pointers
raise Internal_Error; -- TODO: change the exception to something else. raise Internal_Error; -- TODO: change the exception to something else.
@ -916,7 +908,6 @@ end if;
Count: in Object_Size) is Count: in Object_Size) is
Top: Top_Record renames Interp.Top; Top: Top_Record renames Interp.Top;
begin begin
--Ada.Text_IO.Put_Line ("Pop_Top");
if Top.Last < Count then if Top.Last < Count then
-- Something is wrong. Too few temporary object pointers -- Something is wrong. Too few temporary object pointers
raise Internal_Error; -- TODO: change the exception to something else. raise Internal_Error; -- TODO: change the exception to something else.
@ -944,8 +935,8 @@ end if;
Push_Top (Interp.all, Aliased_Cdr'Unchecked_Access); Push_Top (Interp.all, Aliased_Cdr'Unchecked_Access);
Cons := Allocate_Pointer_Object (Interp, Cons_Object_Size, Nil_Pointer); Cons := Allocate_Pointer_Object (Interp, Cons_Object_Size, Nil_Pointer);
Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car; -- TODO: is this really a good idea? resise this... Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car;
Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr; -- If so, use Verify_pointer after Allocate_XXX Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr;
Cons.Tag := Cons_Object; Cons.Tag := Cons_Object;
Pop_Tops (Interp.all, 2); Pop_Tops (Interp.all, 2);
@ -989,7 +980,6 @@ end if;
Source.Pointer_Slot(Cons_Cdr_Index) := Value; Source.Pointer_Slot(Cons_Cdr_Index) := Value;
end Set_Cdr; end Set_Cdr;
function Reverse_Cons (Source: in Object_Pointer; function Reverse_Cons (Source: in Object_Pointer;
Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is
pragma Assert (Is_Cons(Source)); pragma Assert (Is_Cons(Source));
@ -1000,20 +990,15 @@ end if;
Next: Object_Pointer; Next: Object_Pointer;
Prev: Object_Pointer; Prev: Object_Pointer;
begin begin
--Prev := Nil_Pointer;
Prev := Last_Cdr; Prev := Last_Cdr;
Ptr := Source; Ptr := Source;
loop loop
Next := Get_Cdr(Ptr); Next := Get_Cdr(Ptr);
Set_Cdr (Ptr, Prev); Set_Cdr (Ptr, Prev);
Prev := Ptr; Prev := Ptr;
if Is_Cons(Next) then exit when not Is_Cons(Next);
Ptr := Next; Ptr := Next;
else
exit;
end if;
end loop; end loop;
return Ptr; return Ptr;
end Reverse_Cons; end Reverse_Cons;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
@ -1052,29 +1037,26 @@ Ada.Text_IO.Put_Line ("Make_String...");
Car: Object_Pointer renames Ptr.Pointer_Slot(Cons_Car_Index); Car: Object_Pointer renames Ptr.Pointer_Slot(Cons_Car_Index);
Cdr: Object_Pointer renames Ptr.Pointer_Slot(Cons_Cdr_Index); Cdr: Object_Pointer renames Ptr.Pointer_Slot(Cons_Cdr_Index);
begin begin
--Text_IO.Put_Line (Car.Kind'Img & Car.Tag'Img & Object_Word'Image(Pointer_To_Word(Car)));
pragma Assert (Car.Tag = Symbol_Object); pragma Assert (Car.Tag = Symbol_Object);
--if Match_Character_Object(Car, Source) then
if Car.Character_Slot = Source then if Car.Character_Slot = Source then
-- the character string contents are the same.
return Car; return Car;
--Print_Object_Pointer ("Make_Symbol Result (Existing) - " & Source, Car);
end if; end if;
Ptr := Cdr; Ptr := Cdr;
end; end;
end loop; end loop;
--Text_IO.Put_Line ("Creating a symbol .. " & Source);
-- Create a symbol object -- Create a symbol object
Ptr := Allocate_Character_Object (Interp, Source); Ptr := Allocate_Character_Object(Interp, Source);
Ptr.Tag := Symbol_Object; Ptr.Tag := Symbol_Object;
-- Make it safe from GC -- Make Ptr safe from GC
Push_Top (Interp.all, Ptr'Unchecked_Access); Push_Top (Interp.all, Ptr'Unchecked_Access);
-- Link the symbol to the symbol table. -- Link the symbol to the symbol table.
Interp.Symbol_Table := Make_Cons (Interp.Self, Ptr, Interp.Symbol_Table); Interp.Symbol_Table := Make_Cons(Interp.Self, Ptr, Interp.Symbol_Table);
Pop_Tops (Interp.all, 1); Pop_Tops (Interp.all, 1);
@ -1351,6 +1333,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Value: in Object_Pointer) is Value: in Object_Pointer) is
pragma Inline (Chain_Frame_Result); pragma Inline (Chain_Frame_Result);
pragma Assert (Is_Frame(Frame)); pragma Assert (Is_Frame(Frame));
V: Object_Pointer;
begin begin
-- Add a new cons cell to the front -- Add a new cons cell to the front
@ -1359,8 +1342,13 @@ Ada.Text_IO.Put_Line ("Make_String...");
-- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Result_Index)); -- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Result_Index));
--Pop_Tops (Interp, 1); --Pop_Tops (Interp, 1);
Interp.Stack.Pointer_Slot(Frame_Result_Index) := -- This seems to cause a problem if Interp.Stack changes in Make_Cons().
Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index)); --Interp.Stack.Pointer_Slot(Frame_Result_Index) :=
-- Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
-- So, let's separate the evaluation and the assignment.
V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index));
Interp.Stack.Pointer_Slot(Frame_Result_Index) := V;
end Chain_Frame_Result; end Chain_Frame_Result;
procedure Clear_Frame_Result (Frame: in Object_Pointer) is procedure Clear_Frame_Result (Frame: in Object_Pointer) is
@ -1829,7 +1817,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
end if; end if;
Cdr := Get_Cdr(Cons); Cdr := Get_Cdr(Cons);
if Is_Cons (Cdr) then if Is_Cons(Cdr) then
Ada.Text_IO.Put (" "); Ada.Text_IO.Put (" ");
Cons := Cdr; Cons := Cdr;
exit when Cons = Nil_Pointer; exit when Cons = Nil_Pointer;
@ -1858,8 +1846,6 @@ Ada.Text_IO.Put_Line ("Make_String...");
if DEBUG_GC then if DEBUG_GC then
ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX NO PROINTING XXXXXXXXXXXXXXXXXXXXXXXxxx"); ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX NO PROINTING XXXXXXXXXXXXXXXXXXXXXXXxxx");
return; return;
else
ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX TTTTTTTTTTTTTTTTTTTT XXXXXXXXXXXXXXXXXXXXXXXxxx");
end if; end if;
-- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap. -- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap.
-- This way, the stack frame doesn't have to be managed by GC. -- This way, the stack frame doesn't have to be managed by GC.
@ -1941,25 +1927,9 @@ end if;
procedure Push_Frame (Interp: in out Interpreter_Record; procedure Push_Frame (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type; Opcode: in Opcode_Type;
Operand: in Object_Pointer) is Operand: in Object_Pointer) is
--pragma Inline (Push_Frame); pragma Inline (Push_Frame);
begin begin
if IS_NORMAL_POINTER(Interp.Stack) then Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Interp.Environment);
declare
X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
begin
Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME BEFORE] Stack in HEAP: " & Heap_Number'Image(X));
Print_Object_Pointer ("$$$$ -> Stack ", Interp.Stack);
end;
else
Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME BEFORE] Stack NULL");
end if;
Interp.Stack := Make_Frame (Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Interp.Environment);
declare
X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
begin
Ada.Text_IO.Put_Line ("$$$$ [PUSH FRAME AFTER] Stack in HEAP: " & Heap_Number'Image(X));
Print_Object_Pointer ("$$$$ -> Stack ", Interp.Stack);
end;
end Push_Frame; end Push_Frame;
--procedure Pop_Frame (Interp.Stack: out Object_Pointer; --procedure Pop_Frame (Interp.Stack: out Object_Pointer;
@ -1974,16 +1944,11 @@ end;
--end Pop_Frame; --end Pop_Frame;
procedure Pop_Frame (Interp: in out Interpreter_Record) is procedure Pop_Frame (Interp: in out Interpreter_Record) is
--pragma Inline (Pop_Frame); pragma Inline (Pop_Frame);
begin begin
pragma Assert (Interp.Stack /= Nil_Pointer); pragma Assert (Interp.Stack /= Nil_Pointer);
Interp.Environment := Interp.Stack.Pointer_Slot(Frame_Environment_Index); -- restore environment Interp.Environment := Interp.Stack.Pointer_Slot(Frame_Environment_Index); -- restore environment
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
declare
X: Heap_Number := Get_Heap_Number(Interp.Self, Interp.Stack);
begin
Ada.Text_IO.Put_Line ("$$$$ [POP FRAME] Stack in HEAP: " & Heap_Number'Image(X));
end;
end Pop_Frame; end Pop_Frame;
procedure Execute (Interp: in out Interpreter_Record) is separate; procedure Execute (Interp: in out Interpreter_Record) is separate;
@ -2026,14 +1991,13 @@ Print_Object_Pointer ("STACK IN EVALUTE => ", Interp.Stack);
begin begin
pragma Assert (Interp.Base_Input.Stream /= null); pragma Assert (Interp.Base_Input.Stream /= null);
DEBUG_GC := Standard.True; --DEBUG_GC := Standard.True;
Clear_Tops (Interp); Clear_Tops (Interp);
Result := Nil_Pointer; Result := Nil_Pointer;
loop loop
pragma Assert (Interp.Stack = Nil_Pointer); pragma Assert (Interp.Stack = Nil_Pointer);
Interp.Stack := Nil_Pointer; Interp.Stack := Nil_Pointer;
Print_Object_Pointer ("STACK IN Run_Loop => ", Interp.Stack);
Push_Frame (Interp, Opcode_Exit, Nil_Pointer); Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
--Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer); --Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer);

2
lib/h2-scheme.ads
View File

@ -490,8 +490,6 @@ private
Token: Token_Record; Token: Token_Record;
LC_Unfetched: Standard.Boolean := Standard.False; LC_Unfetched: Standard.Boolean := Standard.False;
STACK_XXX: aliased Object_Pointer := Nil_Pointer;
end record; end record;
package Token is package Token is