diff options
Diffstat (limited to 'psl/psl-optimize.adb')
| -rw-r--r-- | psl/psl-optimize.adb | 460 |
1 files changed, 460 insertions, 0 deletions
diff --git a/psl/psl-optimize.adb b/psl/psl-optimize.adb new file mode 100644 index 0000000..4ca62b8 --- /dev/null +++ b/psl/psl-optimize.adb @@ -0,0 +1,460 @@ +with Types; use Types; +with PSL.NFAs.Utils; use PSL.NFAs.Utils; +with PSL.CSE; + +package body PSL.Optimize is + procedure Push (Head : in out NFA_State; S : NFA_State) is + begin + Set_State_User_Link (S, Head); + Head := S; + end Push; + + procedure Pop (Head : in out NFA_State; S : out NFA_State) is + begin + S := Head; + Head := Get_State_User_Link (S); + end Pop; + + procedure Remove_Unreachable_States (N : NFA) + is + Head : NFA_State; + Start, Final : NFA_State; + E : NFA_Edge; + S, N_S : NFA_State; + begin + -- Remove unreachable states, ie states that can't be reached from + -- start state. + Start := Get_Start_State (N); + Final := Get_Final_State (N); + + Head := No_State; + + -- The start state is reachable. + Push (Head, Start); + Set_State_Flag (Start, True); + + -- Follow edges and mark reachable states. + while Head /= No_State loop + Pop (Head, S); + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + S := Get_Edge_Dest (E); + if not Get_State_Flag (S) then + Push (Head, S); + Set_State_Flag (S, True); + end if; + E := Get_Next_Src_Edge (E); + end loop; + end loop; + + -- Remove unreachable states. + S := Get_First_State (N); + while S /= No_State loop + N_S := Get_Next_State (S); + if Get_State_Flag (S) then + -- Clean-up. + Set_State_Flag (S, False); + elsif S = Final then + -- Do not remove final state! + -- FIXME: deconnect state? + null; + else + Remove_State (N, S); + end if; + S := N_S; + end loop; + + -- Remove no-where states, ie states that can't reach the final state. + Head := No_State; + + -- The final state can reach the final state. + Push (Head, Final); + Set_State_Flag (Final, True); + + -- Follow edges and mark reachable states. + while Head /= No_State loop + Pop (Head, S); + E := Get_First_Dest_Edge (S); + while E /= No_Edge loop + S := Get_Edge_Src (E); + if not Get_State_Flag (S) then + Push (Head, S); + Set_State_Flag (S, True); + end if; + E := Get_Next_Dest_Edge (E); + end loop; + end loop; + + -- Remove unreachable states. + S := Get_First_State (N); + while S /= No_State loop + N_S := Get_Next_State (S); + if Get_State_Flag (S) then + -- Clean-up. + Set_State_Flag (S, False); + elsif S = Start then + -- Do not remove start state! + -- FIXME: deconnect state? + null; + else + Remove_State (N, S); + end if; + S := N_S; + end loop; + end Remove_Unreachable_States; + + procedure Remove_Simple_Prefix (N : NFA) + is + Start : NFA_State; + D : NFA_State; + T_Start, T_D, Next_T_D : NFA_Edge; + T_Expr : Node; + Clean : Boolean := False; + begin + Start := Get_Start_State (N); + + -- Iterate on edges from the start state. + T_Start := Get_First_Src_Edge (Start); + while T_Start /= No_Edge loop + -- Edge destination. + D := Get_Edge_Dest (T_Start); + T_Expr := Get_Edge_Expr (T_Start); + + -- Iterate on destination incoming edges. + T_D := Get_First_Dest_Edge (D); + while T_D /= No_Edge loop + Next_T_D := Get_Next_Dest_Edge (T_D); + -- Remove parallel edge. + if T_D /= T_Start + and then Get_Edge_Expr (T_D) = T_Expr + then + Remove_Edge (T_D); + Clean := True; + end if; + T_D := Next_T_D; + end loop; + T_Start := Get_Next_Src_Edge (T_Start); + end loop; + if Clean then + Remove_Unreachable_States (N); + end if; + end Remove_Simple_Prefix; + + -- Return TRUE iff the outgoing or incoming edges of L and R are the same. + -- Outgoing edges must be sorted. + generic + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State; + function Are_States_Identical_Gen (L, R : NFA_State) return Boolean; + + function Are_States_Identical_Gen (L, R : NFA_State) return Boolean + is + L_E, R_E : NFA_Edge; + L_S, R_S : NFA_State; + begin + L_E := Get_First_Edge (L); + R_E := Get_First_Edge (R); + loop + if L_E = No_Edge and then R_E = No_Edge then + -- End of chain for both L and R -> identical states. + return True; + elsif L_E = No_Edge or R_E = No_Edge then + -- End of chain for either L or R -> non identical states. + return False; + elsif Get_Edge_Expr (L_E) /= Get_Edge_Expr (R_E) then + -- Different edge (different expressions). + return False; + end if; + L_S := Get_Edge_State_Reverse (L_E); + R_S := Get_Edge_State_Reverse (R_E); + if L_S /= R_S and then (L_S /= L or else R_S /= R) then + -- Predecessors are differents and not loop. + return False; + end if; + L_E := Get_Next_Edge (L_E); + R_E := Get_Next_Edge (R_E); + end loop; + end Are_States_Identical_Gen; + + generic + with procedure Sort_Edges (N : NFA); + with procedure Sort_Edges_Reverse (S : NFA_State); + with function Get_First_Edge (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge (E : NFA_Edge) return NFA_Edge; + with function Get_First_Edge_Reverse (S : NFA_State) return NFA_Edge; + with function Get_Next_Edge_Reverse (E : NFA_Edge) return NFA_Edge; + with function Get_Edge_State (E : NFA_Edge) return NFA_State; + with function Get_Edge_State_Reverse (E : NFA_Edge) return NFA_State; + with procedure Merge_State_Reverse (N : NFA; + S : NFA_State; S1 : NFA_State); + procedure Merge_Identical_States_Gen (N : NFA); + + procedure Merge_Identical_States_Gen (N : NFA) + is + function Are_States_Identical is new Are_States_Identical_Gen + (Get_First_Edge => Get_First_Edge, + Get_Next_Edge => Get_Next_Edge, + Get_Edge_State_Reverse => Get_Edge_State_Reverse); + + S : NFA_State; + E : NFA_Edge; + E_State, Next_E_State : NFA_State; + Next_E, Next_Next_E : NFA_Edge; + begin + Sort_Edges (N); + + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + Sort_Edges_Reverse (S); + + -- Iterate on incoming edges. + E := Get_First_Edge_Reverse (S); + while E /= No_Edge loop + E_State := Get_Edge_State (E); + + -- Try to merge E with its successors. + Next_E := Get_Next_Edge_Reverse (E); + while Next_E /= No_Edge + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + loop + Next_E_State := Get_Edge_State (Next_E); + Next_Next_E := Get_Next_Edge_Reverse (Next_E); + if Next_E_State = E_State then + -- Identical edge: remove the duplicate. + Remove_Edge (Next_E); + elsif Are_States_Identical (E_State, Next_E_State) then + Merge_State_Reverse (N, E_State, Next_E_State); + end if; + Next_E := Next_Next_E; + end loop; + + E := Get_Next_Edge_Reverse (E); + end loop; + + S := Get_Next_State (S); + end loop; + end Merge_Identical_States_Gen; + + procedure Merge_Identical_States_Src is new Merge_Identical_States_Gen + (Sort_Edges => Sort_Src_Edges, + Sort_Edges_Reverse => Sort_Dest_Edges, + Get_First_Edge => Get_First_Src_Edge, + Get_Next_Edge => Get_Next_Src_Edge, + Get_First_Edge_Reverse => Get_First_Dest_Edge, + Get_Next_Edge_Reverse => Get_Next_Dest_Edge, + Get_Edge_State => Get_Edge_Src, + Get_Edge_State_Reverse => Get_Edge_Dest, + Merge_State_Reverse => Merge_State_Dest); + + procedure Merge_Identical_States_Dest is new Merge_Identical_States_Gen + (Sort_Edges => Sort_Dest_Edges, + Sort_Edges_Reverse => Sort_Src_Edges, + Get_First_Edge => Get_First_Dest_Edge, + Get_Next_Edge => Get_Next_Dest_Edge, + Get_First_Edge_Reverse => Get_First_Src_Edge, + Get_Next_Edge_Reverse => Get_Next_Src_Edge, + Get_Edge_State => Get_Edge_Dest, + Get_Edge_State_Reverse => Get_Edge_Src, + Merge_State_Reverse => Merge_State_Src); + + procedure Merge_Identical_States (N : NFA) is + begin + Merge_Identical_States_Src (N); + Merge_Identical_States_Dest (N); + end Merge_Identical_States; + + procedure Merge_Edges (N : NFA) + is + use PSL.CSE; + Nbr_States : Natural; + begin + Labelize_States (N, Nbr_States); + declare + Last_State : constant Int32 := Int32 (Nbr_States) - 1; + type Edge_Array is array (0 .. Last_State) of NFA_Edge; + Edges : Edge_Array; + S, D : NFA_State; + L_D : Int32; + E, Next_E : NFA_Edge; + begin + -- Iterate on states. + S := Get_First_State (N); + while S /= No_State loop + + Edges := (others => No_Edge); + E := Get_First_Src_Edge (S); + while E /= No_Edge loop + Next_E := Get_Next_Src_Edge (E); + D := Get_Edge_Dest (E); + L_D := Get_State_Label (D); + if Edges (L_D) /= No_Edge then + Set_Edge_Expr + (Edges (L_D), + Build_Bool_Or (Get_Edge_Expr (Edges (L_D)), + Get_Edge_Expr (E))); + -- FIXME: reduce expression. + Remove_Edge (E); + else + Edges (L_D) := E; + end if; + E := Next_E; + end loop; + + S := Get_Next_State (S); + end loop; + end; + end Merge_Edges; + + procedure Remove_Identical_Src_Edges (S : NFA_State) + is + Next_E, E : NFA_Edge; + begin + Sort_Src_Edges (S); + E := Get_First_Src_Edge (S); + if E = No_Edge then + return; + end if; + loop + Next_E := Get_Next_Src_Edge (E); + exit when Next_E = No_Edge; + if Get_Edge_Dest (E) = Get_Edge_Dest (Next_E) + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + then + Remove_Edge (Next_E); + else + E := Next_E; + end if; + end loop; + end Remove_Identical_Src_Edges; + + procedure Remove_Identical_Dest_Edges (S : NFA_State) + is + Next_E, E : NFA_Edge; + begin + Sort_Dest_Edges (S); + E := Get_First_Dest_Edge (S); + if E = No_Edge then + return; + end if; + loop + Next_E := Get_Next_Dest_Edge (E); + exit when Next_E = No_Edge; + if Get_Edge_Src (E) = Get_Edge_Src (Next_E) + and then Get_Edge_Expr (E) = Get_Edge_Expr (Next_E) + then + Remove_Edge (Next_E); + else + E := Next_E; + end if; + end loop; + end Remove_Identical_Dest_Edges; + + procedure Find_Partitions (N : NFA; Nbr_States : Natural) + is + Last_State : constant NFA_State := NFA_State (Nbr_States) - 1; + type Part_Offset is new Int32 range -1 .. Nat32 (Nbr_States - 1); + type Part_Id is new Part_Offset range 0 .. Part_Offset'Last; + + -- State to partition id. + State_Part : array (0 .. Last_State) of Part_Id; + pragma Unreferenced (State_Part); + + -- Last partition index. + Last_Part : Part_Id; + + -- Partitions content. + + -- To get the states in a partition P, first get the offset OFF + -- (from Offsets) of P. States are in Parts (OFF ...). The + -- number of states is not known, but they all belong to P + -- (check with STATE_PART). + Parts : array (Part_Offset) of NFA_State; + type Offset_Array is array (Part_Id) of Part_Offset; + Start_Offsets : Offset_Array; + Last_Offsets : Offset_Array; + + S, Final_State : NFA_State; + First_S : NFA_State; + Off, Last_Off : Part_Offset; + + Stable, Stable1 : Boolean; + + function Is_Equivalent (L, R : NFA_State) return Boolean is + begin + raise Program_Error; + return False; + end Is_Equivalent; + begin + -- Return now for trivial cases (0 or 1 state). + if Nbr_States < 2 then + return; + end if; + + -- Partition 1 contains the final state. + -- Partition 0 contains the other states. + Final_State := Get_Final_State (N); + Last_Part := 1; + State_Part := (others => 0); + State_Part (Final_State) := 1; + S := Get_First_State (N); + Off := -1; + while S /= No_State loop + if S /= Last_State then + Off := Off + 1; + Parts (Off) := S; + end if; + S := Get_Next_State (S); + end loop; + Start_Offsets (0) := 0; + Last_Offsets (0) := Off; + Start_Offsets (1) := Off + 1; + Last_Offsets (1) := Off + 1; + Parts (Off + 1) := Final_State; + + -- Now the hard work. + loop + Stable := True; + -- For every partition + for P in 0 .. Last_Part loop + Off := Start_Offsets (P); + First_S := Parts (Off); + Off := Off + 1; + + -- For every S != First_S in P. + Last_Off := Last_Offsets (P); + Stable1 := True; + while Off <= Last_Off loop + S := Parts (Off); + + if not Is_Equivalent (First_S, S) then + -- Swap S with the last element of the partition. + Parts (Off) := Parts (Last_Off); + Parts (Last_Off) := S; + -- Reduce partition size. + Last_Off := Last_Off - 1; + Last_Offsets (P) := Last_Off; + + if Stable1 then + -- Create a new partition. + Last_Part := Last_Part + 1; + Last_Offsets (Last_Part) := Last_Off + 1; + Stable1 := False; + end if; + -- Put S in the new partition. + Start_Offsets (Last_Part) := Last_Off + 1; + State_Part (S) := Last_Part; + Stable := False; + + -- And continue with the swapped state. + else + Off := Off + 1; + end if; + end loop; + end loop; + exit when Stable; + end loop; + end Find_Partitions; + pragma Unreferenced (Find_Partitions); +end PSL.Optimize; |