From d985daf8d54419f00adde0292cbf5a2cf0376609 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 22 May 2019 18:38:12 +0200 Subject: vhdl: add hook on free_node, automatically free --- src/vhdl/vhdl-elocations.adb | 22 ++++++++++++++++++++- src/vhdl/vhdl-elocations.adb.in | 22 ++++++++++++++++++++- src/vhdl/vhdl-elocations.ads | 4 ---- src/vhdl/vhdl-nodes.adb | 43 +++++++++++++++++++++++++++++++---------- src/vhdl/vhdl-nodes.adb.in | 43 +++++++++++++++++++++++++++++++---------- src/vhdl/vhdl-nodes.ads | 4 ++++ src/vhdl/vhdl-parse.adb | 3 --- 7 files changed, 112 insertions(+), 29 deletions(-) diff --git a/src/vhdl/vhdl-elocations.adb b/src/vhdl/vhdl-elocations.adb index 0ba3d0b0e..8bc68245c 100644 --- a/src/vhdl/vhdl-elocations.adb +++ b/src/vhdl/vhdl-elocations.adb @@ -130,14 +130,31 @@ package body Vhdl.Elocations is Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location); end Create_Elocations; - procedure Delete_Elocations (N : Iir) is + procedure Delete_Elocations (N : Iir) + is + use Vhdl.Nodes_Priv; + Old : Location_Index_Type; begin + -- Cannot delete an already deleted location. + if N > Elocations_Index_Table.Last then + return; + end if; + Old := Elocations_Index_Table.Table (N); + if Old = No_Location_Index then + return; + end if; + -- Clear the corresponding index. Elocations_Index_Table.Table (N) := No_Location_Index; -- FIXME: keep free slots in chained list ? end Delete_Elocations; + procedure Free_Hook (N : Iir) is + begin + Delete_Elocations (N); + end Free_Hook; + generic Off : Location_Index_Type; function Get_FieldX (N : Iir) return Location_Type; @@ -707,4 +724,7 @@ package body Vhdl.Elocations is Set_Field3 (N, Loc); end Set_Assign_Location; + +begin + Vhdl.Nodes.Register_Free_Hook (Free_Hook'Access); end Vhdl.Elocations; diff --git a/src/vhdl/vhdl-elocations.adb.in b/src/vhdl/vhdl-elocations.adb.in index 80fab21ce..164fdb00c 100644 --- a/src/vhdl/vhdl-elocations.adb.in +++ b/src/vhdl/vhdl-elocations.adb.in @@ -130,14 +130,31 @@ package body Vhdl.Elocations is Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location); end Create_Elocations; - procedure Delete_Elocations (N : Iir) is + procedure Delete_Elocations (N : Iir) + is + use Vhdl.Nodes_Priv; + Old : Location_Index_Type; begin + -- Cannot delete an already deleted location. + if N > Elocations_Index_Table.Last then + return; + end if; + Old := Elocations_Index_Table.Table (N); + if Old = No_Location_Index then + return; + end if; + -- Clear the corresponding index. Elocations_Index_Table.Table (N) := No_Location_Index; -- FIXME: keep free slots in chained list ? end Delete_Elocations; + procedure Free_Hook (N : Iir) is + begin + Delete_Elocations (N); + end Free_Hook; + generic Off : Location_Index_Type; function Get_FieldX (N : Iir) return Location_Type; @@ -185,4 +202,7 @@ package body Vhdl.Elocations is procedure Set_Field6 is new Set_FieldX (6); -- Subprograms + +begin + Vhdl.Nodes.Register_Free_Hook (Free_Hook'Access); end Vhdl.Elocations; diff --git a/src/vhdl/vhdl-elocations.ads b/src/vhdl/vhdl-elocations.ads index 14c33999f..fa895e111 100644 --- a/src/vhdl/vhdl-elocations.ads +++ b/src/vhdl/vhdl-elocations.ads @@ -631,10 +631,6 @@ package Vhdl.Elocations is -- Allocate memory to store elocations for node N. Must be called once. procedure Create_Elocations (N : Iir); - -- Delete locations. Memory is not yet reclaimed (but doesn't happen - -- frequently). - procedure Delete_Elocations (N : Iir); - -- General methods. -- Field: Field1 diff --git a/src/vhdl/vhdl-nodes.adb b/src/vhdl/vhdl-nodes.adb index 71f1eb722..7a532c113 100644 --- a/src/vhdl/vhdl-nodes.adb +++ b/src/vhdl/vhdl-nodes.adb @@ -355,17 +355,40 @@ package body Vhdl.Nodes is return Res; end Create_Node; - procedure Free_Node (N : Node_Type) - is + type Free_Node_Hook_Array is + array (Natural range 1 .. 8) of Free_Iir_Hook; + Nbr_Free_Hooks : Natural := 0; + + Free_Hooks : Free_Node_Hook_Array; + + procedure Register_Free_Hook (Hook : Free_Iir_Hook) is begin - if N /= Null_Node then - Set_Nkind (N, 0); - Set_Field1 (N, Free_Chain); - Free_Chain := N; - if Nodet.Table (N).Format = Format_Medium then - Set_Field1 (N + 1, Free_Chain); - Free_Chain := N + 1; - end if; + if Nbr_Free_Hooks >= Free_Hooks'Last then + -- Not enough room in Free_Hooks. + raise Internal_Error; + end if; + Nbr_Free_Hooks := Nbr_Free_Hooks + 1; + Free_Hooks (Nbr_Free_Hooks) := Hook; + end Register_Free_Hook; + + procedure Free_Node (N : Node_Type) is + begin + if N = Null_Node then + return; + end if; + + -- Call hooks. + for I in Free_Hooks'First .. Nbr_Free_Hooks loop + Free_Hooks (I).all (N); + end loop; + + -- Really free the node. + Set_Nkind (N, 0); + Set_Field1 (N, Free_Chain); + Free_Chain := N; + if Nodet.Table (N).Format = Format_Medium then + Set_Field1 (N + 1, Free_Chain); + Free_Chain := N + 1; end if; end Free_Node; diff --git a/src/vhdl/vhdl-nodes.adb.in b/src/vhdl/vhdl-nodes.adb.in index 761676b3b..b19174d3f 100644 --- a/src/vhdl/vhdl-nodes.adb.in +++ b/src/vhdl/vhdl-nodes.adb.in @@ -355,17 +355,40 @@ package body Vhdl.Nodes is return Res; end Create_Node; - procedure Free_Node (N : Node_Type) - is + type Free_Node_Hook_Array is + array (Natural range 1 .. 8) of Free_Iir_Hook; + Nbr_Free_Hooks : Natural := 0; + + Free_Hooks : Free_Node_Hook_Array; + + procedure Register_Free_Hook (Hook : Free_Iir_Hook) is begin - if N /= Null_Node then - Set_Nkind (N, 0); - Set_Field1 (N, Free_Chain); - Free_Chain := N; - if Nodet.Table (N).Format = Format_Medium then - Set_Field1 (N + 1, Free_Chain); - Free_Chain := N + 1; - end if; + if Nbr_Free_Hooks >= Free_Hooks'Last then + -- Not enough room in Free_Hooks. + raise Internal_Error; + end if; + Nbr_Free_Hooks := Nbr_Free_Hooks + 1; + Free_Hooks (Nbr_Free_Hooks) := Hook; + end Register_Free_Hook; + + procedure Free_Node (N : Node_Type) is + begin + if N = Null_Node then + return; + end if; + + -- Call hooks. + for I in Free_Hooks'First .. Nbr_Free_Hooks loop + Free_Hooks (I).all (N); + end loop; + + -- Really free the node. + Set_Nkind (N, 0); + Set_Field1 (N, Free_Chain); + Free_Chain := N; + if Nodet.Table (N).Format = Format_Medium then + Set_Field1 (N + 1, Free_Chain); + Free_Chain := N + 1; end if; end Free_Node; diff --git a/src/vhdl/vhdl-nodes.ads b/src/vhdl/vhdl-nodes.ads index 51a147921..d3efa1814 100644 --- a/src/vhdl/vhdl-nodes.ads +++ b/src/vhdl/vhdl-nodes.ads @@ -5871,6 +5871,10 @@ package Vhdl.Nodes is function Create_Iir_Error return Iir; procedure Free_Iir (Target : Iir); + -- Hooks called when a node is free. + type Free_Iir_Hook is access procedure (N : Iir); + procedure Register_Free_Hook (Hook : Free_Iir_Hook); + -- Free all and reinit. procedure Initialize; diff --git a/src/vhdl/vhdl-parse.adb b/src/vhdl/vhdl-parse.adb index f111d6cf8..cbf979fb9 100644 --- a/src/vhdl/vhdl-parse.adb +++ b/src/vhdl/vhdl-parse.adb @@ -1620,9 +1620,6 @@ package body Vhdl.Parse is Last := N_Interface; Inter := Get_Chain (O_Interface); - if Flag_Elocations then - Delete_Elocations (O_Interface); - end if; Free_Iir (O_Interface); O_Interface := Inter; end loop; -- cgit v1.2.3