diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index a108545..72c05bd 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -188,13 +188,11 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; declare - Closure: aliased Object_Pointer; + Closure: Object_Pointer; begin -Push_Top (Interp, Closure'Unchecked_Access); -- not necessary Closure := Make_Closure (Interp.Self, Operand, Interp.Environment); Pop_Frame (Interp); -- Done Chain_Frame_Result (Interp, Interp.Stack, Closure); -Pop_Tops (Interp, 1); -- not necessary end; end if; @@ -389,7 +387,6 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car); -- Push a new environmen for the closure 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); 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; 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_Operand (Interp.Stack, Fbody); Clear_Frame_Result (Interp.Stack); @@ -456,10 +452,6 @@ Print (Interp, 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 when Procedure_Object => case Get_Procedure_Opcode(Func) is @@ -700,7 +692,7 @@ Print (Interp, Operand); end Fetch_Token; procedure Read_List is - --pragma Inline (Read_List); + pragma Inline (Read_List); V: aliased Object_Pointer; begin -- This procedure reads each token in a list. @@ -710,7 +702,7 @@ Print (Interp, Operand); Fetch_Token; - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); case Interp.Token.Kind is when End_Token => @@ -751,18 +743,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); Chain_Frame_Result (Interp, Interp.Stack, V); 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)); -Print_Object_Pointer ("111 Identifier => Stack => ", Interp.Stack); Chain_Frame_Result (Interp, Interp.Stack, V); -Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack); when others => -- TODO: set various error info raise Syntax_Error; end case; - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Read_List; procedure Read_List_Cdr is @@ -776,7 +765,7 @@ Print_Object_Pointer ("222 Identifier => Stack => ", Interp.Stack); -- to handle the head item specially. Fetch_Token; - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); case Interp.Token.Kind is when End_Token => @@ -801,13 +790,11 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); when String_Token => 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); Chain_Frame_Result (Interp, Interp.Stack, V); when Identifier_Token => 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); Chain_Frame_Result (Interp, Interp.Stack, V); @@ -816,7 +803,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); raise Syntax_Error; end case; - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Read_List_Cdr; procedure Read_List_End is @@ -825,42 +812,42 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); begin Fetch_Token; - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); case Interp.Token.Kind is when Right_Parenthesis_Token => V := Get_Frame_Result(Interp.Stack); pragma Assert (V /= Nil_Pointer); -- 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); Chain_Frame_Result (Interp, Interp.Stack, V); when others => raise Syntax_Error; end case; - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Read_List_End; procedure Close_List is pragma Inline (Close_List); V: aliased Object_Pointer; begin - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); V := Get_Frame_Result(Interp.Stack); pragma Assert (Get_Cdr(V) = Nil_Pointer); Pop_Frame (Interp); -- Done with the current frame Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V)); - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Close_List; procedure Close_Quote is pragma Inline (Close_Quote); V: aliased Object_Pointer; begin - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); -- TODO: use Interp.Quote_Syntax instead of Make_Symbol("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 Chain_Frame_Result (Interp, Interp.Stack, V); - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Close_Quote; procedure Read_Object is @@ -877,7 +864,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); begin Fetch_Token; - Push_Top (Interp, V'Unchecked_Access); + --Push_Top (Interp, V'Unchecked_Access); case Interp.Token.Kind is when End_Token => @@ -900,13 +887,11 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); when String_Token => 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 Chain_Frame_Result (Interp, Interp.Stack, V); when Identifier_Token => 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 Chain_Frame_Result (Interp, Interp.Stack, V); @@ -915,7 +900,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); raise Syntax_Error; end case; - Pop_Tops (Interp, 1); + --Pop_Tops (Interp, 1); end Read_Object; begin @@ -986,27 +971,6 @@ begin pragma Assert (Interp.Top.Last < Interp.Top.Data'First); 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 when Opcode_Exit => exit; @@ -1047,9 +1011,6 @@ begin end case; end loop; - -- the stack must be empty when the loop is terminated - --pragma Assert (Interp.Stack = Nil_Pointer); - exception when Stream_End_Error => raise; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 2810754..78a676a 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -325,7 +325,10 @@ package body H2.Scheme is Output_Character_Array (Source.Character_Slot); end if; 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 Print_Object_Pointer; @@ -422,6 +425,17 @@ package body H2.Scheme is return Object.New_Pointer; 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; Heap_Bytes: in Heap_Size) return Heap_Element_Pointer is Avail: Heap_Size; @@ -436,7 +450,6 @@ package body H2.Scheme is Avail := Heap.Size - Heap.Bound; if Real_Bytes > Avail then -Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap_Size'Image(Real_Bytes)); return null; end if; @@ -467,6 +480,11 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap return 1; end if; + if Source = Nil_Pointer then +ada.text_io.put_line ("HEAP SOURCE IS NIL"); + return 0; + end if; + raise Internal_Error; end Get_Heap_Number; @@ -514,6 +532,7 @@ Ada.Text_IO.PUt_Line ("Avail: " & Heap_Size'Image(Avail) & " Requested: " & Heap Last_Pos: Heap_Size; New_Heap: Heap_Number; + Original_Symbol_Table: 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 Pred: Object_Pointer; Cons: Object_Pointer; + Car: Object_Pointer; + Cdr: Object_Pointer; begin -- 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 pragma Assert (Cons.Tag = Cons_Object); - declare - Car: Object_Pointer renames Cons.Pointer_Slot(Cons_Car_Index); - Cdr: Object_Pointer renames Cons.Pointer_Slot(Cons_Cdr_Index); - begin - pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object); + Car := Cons.Pointer_Slot(Cons_Car_Index); + Cdr := Cons.Pointer_Slot(Cons_Cdr_Index); + pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object); - if Car.Kind /= Moved_Object and then - (Car.Flags and Syntax_Object) = 0 then - -- A non-syntax symbol has not been moved. - -- Unlink the cons cell from the symbol table. - ---Text_IO.Put_Line ("COMPACT_SYMBOL_TABLE Unlinking " & Character_Array_To_String (Car.Character_Slot)); - if Pred = Nil_Pointer then - Interp.Symbol_Table := Cdr; - else - Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr; - end if; + if Car.Kind /= Moved_Object and then + (Car.Flags and Syntax_Object) = 0 then + -- A non-syntax symbol has not been moved. + -- Unlink the cons cell from the symbol table. + if Pred = Nil_Pointer then + Interp.Symbol_Table := Cdr; + else + Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr; end if; - - Cons := Cdr; - end; + else + Pred := Cons; + end if; + + Cons := Cdr; end loop; end Compact_Symbol_Table; begin -declare -Avail: Heap_Size; -begin -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)); -end; +--declare +--Avail: Heap_Size; +--begin +--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)); +--end; -- As the Heap_Number type is a modular type that can -- represent 0 and 1, incrementing it gives the next value. New_Heap := Interp.Current_Heap + 1; -- Migrate some root objects -Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark); -Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack); +--Print_Object_Pointer (">>> [GC] ROOT OBJECTS ...", Interp.Mark); +--Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack); if Is_Normal_Pointer(Interp.Stack) then 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; -Print_Object_Pointer (">>> [GC] Stack AFTER ...", Interp.Stack); + Interp.Root_Environment := Move_One_Object(Interp.Root_Environment); Interp.Environment := Move_One_Object(Interp.Environment); Interp.Mark := Move_One_Object(Interp.Mark); -- 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 - if Interp.Top.Data(I).all /= null and then - Is_Normal_Pointer(Interp.Top.Data(I).all) then + if Interp.Top.Data(I).all = Interp.Symbol_Table 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); end if; 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 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 -- is not referenced by any other objects than the symbol -- table itself -Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]"); +--Ada.Text_IO.Put_Line (">>> [GC COMPACTING 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 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 -- the previous scan to move referenced objects by -- 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 Interp.Heap(Interp.Current_Heap).Bound := 0; Interp.Current_Heap := New_Heap; -declare -Avail: Heap_Size; -begin -Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound; -Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack); -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; -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; +--declare +--Avail: Heap_Size; +--begin +--Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound; +--Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack); +--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; function Allocate_Bytes (Interp: access Interpreter_Record; @@ -881,28 +889,12 @@ end if; return Result; 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; Source: access Object_Pointer) is Top: Top_Record renames Interp.Top; 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 -- Something is wrong. Too many temporary object pointers raise Internal_Error; -- TODO: change the exception to something else. @@ -916,7 +908,6 @@ end if; Count: in Object_Size) is Top: Top_Record renames Interp.Top; begin ---Ada.Text_IO.Put_Line ("Pop_Top"); if Top.Last < Count then -- Something is wrong. Too few temporary object pointers raise Internal_Error; -- TODO: change the exception to something else. @@ -944,8 +935,8 @@ end if; Push_Top (Interp.all, Aliased_Cdr'Unchecked_Access); 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_Cdr_Index) := Aliased_Cdr; -- If so, use Verify_pointer after Allocate_XXX + Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car; + Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr; Cons.Tag := Cons_Object; Pop_Tops (Interp.all, 2); @@ -989,7 +980,6 @@ end if; Source.Pointer_Slot(Cons_Cdr_Index) := Value; end Set_Cdr; - function Reverse_Cons (Source: in Object_Pointer; Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is pragma Assert (Is_Cons(Source)); @@ -1000,20 +990,15 @@ end if; Next: Object_Pointer; Prev: Object_Pointer; begin - --Prev := Nil_Pointer; Prev := Last_Cdr; Ptr := Source; loop Next := Get_Cdr(Ptr); Set_Cdr (Ptr, Prev); Prev := Ptr; - if Is_Cons(Next) then - Ptr := Next; - else - exit; - end if; + exit when not Is_Cons(Next); + Ptr := Next; end loop; - return Ptr; end Reverse_Cons; ----------------------------------------------------------------------------- @@ -1052,29 +1037,26 @@ Ada.Text_IO.Put_Line ("Make_String..."); Car: Object_Pointer renames Ptr.Pointer_Slot(Cons_Car_Index); Cdr: Object_Pointer renames Ptr.Pointer_Slot(Cons_Cdr_Index); begin ---Text_IO.Put_Line (Car.Kind'Img & Car.Tag'Img & Object_Word'Image(Pointer_To_Word(Car))); pragma Assert (Car.Tag = Symbol_Object); - --if Match_Character_Object(Car, Source) then if Car.Character_Slot = Source then + -- the character string contents are the same. return Car; ---Print_Object_Pointer ("Make_Symbol Result (Existing) - " & Source, Car); end if; Ptr := Cdr; end; end loop; ---Text_IO.Put_Line ("Creating a symbol .. " & Source); -- Create a symbol object - Ptr := Allocate_Character_Object (Interp, Source); + Ptr := Allocate_Character_Object(Interp, Source); Ptr.Tag := Symbol_Object; - -- Make it safe from GC + -- Make Ptr safe from GC Push_Top (Interp.all, Ptr'Unchecked_Access); -- 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); @@ -1351,6 +1333,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Value: in Object_Pointer) is pragma Inline (Chain_Frame_Result); pragma Assert (Is_Frame(Frame)); + V: Object_Pointer; begin -- 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)); --Pop_Tops (Interp, 1); - Interp.Stack.Pointer_Slot(Frame_Result_Index) := - Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index)); + -- This seems to cause a problem if Interp.Stack changes in Make_Cons(). + --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; procedure Clear_Frame_Result (Frame: in Object_Pointer) is @@ -1829,7 +1817,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); end if; Cdr := Get_Cdr(Cons); - if Is_Cons (Cdr) then + if Is_Cons(Cdr) then Ada.Text_IO.Put (" "); Cons := Cdr; exit when Cons = Nil_Pointer; @@ -1858,8 +1846,6 @@ Ada.Text_IO.Put_Line ("Make_String..."); if DEBUG_GC then ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX NO PROINTING XXXXXXXXXXXXXXXXXXXXXXXxxx"); return; -else -ADA.TEXT_IO.PUT_LINE ("XXXXXXXXXXXXXXXXXXXXXXXXX TTTTTTTTTTTTTTTTTTTT XXXXXXXXXXXXXXXXXXXXXXXxxx"); end if; -- 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. @@ -1941,25 +1927,9 @@ end if; procedure Push_Frame (Interp: in out Interpreter_Record; Opcode: in Opcode_Type; Operand: in Object_Pointer) is - --pragma Inline (Push_Frame); + pragma Inline (Push_Frame); begin -if IS_NORMAL_POINTER(Interp.Stack) then -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; + Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Interp.Environment); end Push_Frame; --procedure Pop_Frame (Interp.Stack: out Object_Pointer; @@ -1974,16 +1944,11 @@ end; --end Pop_Frame; procedure Pop_Frame (Interp: in out Interpreter_Record) is - --pragma Inline (Pop_Frame); + pragma Inline (Pop_Frame); begin pragma Assert (Interp.Stack /= Nil_Pointer); Interp.Environment := Interp.Stack.Pointer_Slot(Frame_Environment_Index); -- restore environment 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; procedure Execute (Interp: in out Interpreter_Record) is separate; @@ -2026,14 +1991,13 @@ Print_Object_Pointer ("STACK IN EVALUTE => ", Interp.Stack); begin pragma Assert (Interp.Base_Input.Stream /= null); -DEBUG_GC := Standard.True; +--DEBUG_GC := Standard.True; Clear_Tops (Interp); Result := Nil_Pointer; loop pragma Assert (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_Print_Result, Nil_Pointer); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 72a01c2..eac1786 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -490,8 +490,6 @@ private Token: Token_Record; LC_Unfetched: Standard.Boolean := Standard.False; - - STACK_XXX: aliased Object_Pointer := Nil_Pointer; end record; package Token is