⟦acba0bd94⟧

TextFile

package body Concurrent_Map_Generic is

    task Serialize is
        entry Define (The_Map : in out Map;
                      D : Domain_Type;
                      R : Range_Type;
                      Trap_Multiples : Boolean := False);
        entry Undefine (The_Map : in out Map; D : Domain_Type);
        entry Make_Empty (The_Map : in out Map);
    end Serialize;


    function Myhash (D : Domain_Type) return Index is
    begin
        return Index (Hash (D) mod Size);
    end Myhash;
    pragma Inline (Myhash);


    function Find (The_Map : Map; D : Domain_Type) return Set is
        -- result = null ==> D not in S
        Rest : Set := The_Map.Bucket (Myhash (D));
    begin
        while Rest /= null and then Rest.Value.D /= D loop
            Rest := Rest.Link;
        end loop;

        if Rest /= null then
            The_Map.Cache := Rest;
        end if;

        return Rest;
    end Find;

    procedure Find (S : Set;
                    D : Domain_Type;
                    Ptr : in out Set;
                    Prev : in out Set) is
        -- ptr = null ==> D not in S
        -- ptr /= null and prev = null ==> D = first element of S
    begin
        Ptr := S;
        Prev := null;
        while (Ptr /= null) and then (Ptr.Value.D /= D) loop
            Prev := Ptr;
            Ptr := Ptr.Link;
        end loop;
    end Find;

    function Eval (The_Map : Map; D : Domain_Type) return Range_Type is
        Cache : Set := The_Map.Cache;
        -- cached pointer value must be fetched only once
        -- since cache may be concurrently updated
    begin
        if Cache /= null then
            declare
                Value : Pair renames Cache.Value;
            begin
                if Value.D = D then
                    return Value.R;
                end if;
            end;
        end if;

        declare
            Ptr : Set := Find (The_Map, D);
        begin
            if Ptr /= null then
                return Ptr.Value.R;
            else
                raise Undefined;
            end if;
        end;
    end Eval;

    procedure Find (The_Map : Map;
                    D : Domain_Type;
                    R : in out Range_Type;
                    Success : out Boolean) is
        Cache : Set := The_Map.Cache;
        -- cached pointer value must be fetched only once
        -- since cache may be concurrently updated
    begin
        if Cache /= null then
            declare
                Value : Pair renames Cache.Value;
            begin
                if Value.D = D then
                    R := Value.R;
                    Success := True;
                    return;
                end if;
            end;
        end if;

        declare
            Ptr : Set := Find (The_Map, D);
        begin
            if Ptr /= null then
                R := Ptr.Value.R;
                Success := True;
            else
                Success := False;
            end if;
        end;
    end Find;

    procedure Find (The_Map : Map;
                    D : Domain_Type;
                    P : in out Pair;
                    Success : out Boolean) is
        Cache : Set := The_Map.Cache;
        -- cached pointer value must be fetched only once
        -- since cache may be concurrently updated
    begin
        if Cache /= null then
            declare
                Value : Pair renames Cache.Value;
            begin
                if Value.D = D then
                    P := Value;
                    Success := True;
                    return;
                end if;
            end;
        end if;

        declare
            Ptr : Set := Find (The_Map, D);
        begin
            if Ptr /= null then
                P := Ptr.Value;
                Success := True;
            else
                Success := False;
            end if;
        end;
    end Find;

    procedure Define (The_Map : in out Map;
                      D : Domain_Type;
                      R : Range_Type;
                      Trap_Multiples : Boolean := False) is
    begin
        Serialize.Define (The_Map, D, R, Trap_Multiples);
    end Define;

    procedure Real_Define (The_Map : in out Map;
                           D : Domain_Type;
                           R : Range_Type;
                           Trap_Multiples : Boolean := False) is
        Cache : Set renames The_Map.Cache;
        -- cache can be written but not fetched
        -- since cache may be concurrently updated
        The_Set : Set renames The_Map.Bucket (Myhash (D));
        Ptr : Set;
        Prev : Set;
    begin
        Find (The_Set, D, Ptr, Prev);

        if Ptr = null then
            The_Set := new Node'(Pair'(D => D, R => R), The_Set);
            Cache := The_Set;
            The_Map.Size := The_Map.Size + 1;
        elsif Trap_Multiples then
            raise Multiply_Defined;
        elsif Prev = null then
            The_Set := new Node'(Pair'(D => D, R => R), Ptr.Link);
            Cache := The_Set;
        else
            Prev.Link := new Node'(Pair'(D => D, R => R), Ptr.Link);
            Cache := Prev.Link;
        end if;
    end Real_Define;

    procedure Undefine (The_Map : in out Map; D : Domain_Type) is
    begin
        Serialize.Undefine (The_Map, D);
    end Undefine;

    procedure Real_Undefine (The_Map : in out Map; D : Domain_Type) is
        Cache : Set renames The_Map.Cache;
        -- cache must be written but not fetched
        -- since cache may be concurrently updated
        Start : Set renames The_Map.Bucket (Myhash (D));
        Current : Set;
        Previous : Set;
    begin
        Find (Start, D, Current, Previous);

        if Current = null then
            raise Undefined;
        elsif Previous = null then
            -- old node cannot be reused due to concurrent readers
            Start := Current.Link;
        else
            -- old node cannot be reused due to concurrent readers
            Previous.Link := Current.Link;
        end if;
        The_Map.Size := The_Map.Size - 1;
        Cache := null;
    end Real_Undefine;

    procedure Copy (Target : in out Map; Source : Map) is
        procedure Copy_Set (Target_Set : in out Set; Source_Set : Set) is
            Rest : Set := Source_Set;
        begin
            Target_Set := null;
            while Rest /= null loop
                Target_Set := new Node'(Rest.Value, Target_Set);
                Target.Size := Target.Size + 1;
                Rest := Rest.Link;
            end loop;
        end Copy_Set;
    begin
        Target.Size := 0;
        for I in Index loop
            Copy_Set (Target_Set => Target.Bucket (I),
                      Source_Set => Source.Bucket (I));
        end loop;
        Target.Cache := null;
    end Copy;

    procedure Initialize (The_Map : out Map) is
    begin
        The_Map := new Map_Data;
    end Initialize;

    function Is_Empty (The_Map : Map) return Boolean is
    begin
        for I in Index loop
            if The_Map.Bucket (I) /= null then
                return False;
            end if;
        end loop;
        return True;
    end Is_Empty;

    procedure Make_Empty (The_Map : in out Map) is
    begin
        Serialize.Make_Empty (The_Map);
    end Make_Empty;

    procedure Real_Make_Empty (The_Map : in out Map) is
    begin
        The_Map.Cache := null;
        for I in Index loop
            The_Map.Bucket (I) := null;
        end loop;
    end Real_Make_Empty;

    procedure Init (Iter : out Iterator; The_Map : Map) is
        The_Iter : Iterator;
    begin
        if The_Map = null then
            Iter.Done := True;
            return;
        end if;

        for I in Index loop
            The_Iter.Set_Iter := The_Map.Bucket (I);
            if The_Iter.Set_Iter /= null then
                The_Iter.Done := False;
                The_Iter.Index_Value := I;
                The_Iter.The_Map := The_Map;
                Iter := The_Iter;
                return;
            end if;
        end loop;
        The_Iter.Done := True;
        Iter := The_Iter;
    end Init;

    procedure Next (Iter : in out Iterator) is
    begin
        Iter.Set_Iter := Iter.Set_Iter.Link;

        while Iter.Set_Iter = null loop
            if Iter.Index_Value = Index'Last then
                Iter.Done := True;
                return;
            end if;
            Iter.Index_Value := Iter.Index_Value + 1;
            Iter.Set_Iter := Iter.The_Map.Bucket (Iter.Index_Value);
        end loop;
    end Next;

    function Value (Iter : Iterator) return Domain_Type is
    begin
        return Iter.Set_Iter.Value.D;
    end Value;

    function Done (Iter : Iterator) return Boolean is
    begin
        return Iter.Done;
    end Done;

    task body Serialize is
    begin
        loop
            begin
                select
                    accept Define (The_Map : in out Map;
                                   D : Domain_Type;
                                   R : Range_Type;
                                   Trap_Multiples : Boolean := False) do
                        Real_Define (The_Map, D, R, Trap_Multiples);
                    end Define;
                or
                    accept Undefine (The_Map : in out Map; D : Domain_Type) do
                        Real_Undefine (The_Map, D);
                    end Undefine;
                or
                    accept Make_Empty (The_Map : in out Map) do
                        Real_Make_Empty (The_Map);
                    end Make_Empty;
                or
                    terminate;
                end select;
            exception
                when others =>
                    null;
            end;
        end loop;
    end Serialize;

    function Nil return Map is
    begin
        return null;
    end Nil;

    function Is_Nil (The_Map : Map) return Boolean is
    begin
        return The_Map = null;
    end Is_Nil;

    function Cardinality (The_Map : Map) return Natural is
    begin
        return The_Map.Size;
    end Cardinality;

end Concurrent_Map_Generic;
DataMuseum.dk

Rational R1000/400 Tapes

⟦acba0bd94⟧ TextFile

Derivation

TextFile
