Patchwork [Ada] Lock free implementation of protected objects

login
register
mail settings
Submitter Arnaud Charlet
Date May 15, 2012, 9:30 a.m.
Message ID <20120515093001.GA27135@adacore.com>
Download mbox | patch
Permalink /patch/159274/
State New
Headers show

Comments

Arnaud Charlet - May 15, 2012, 9:30 a.m.
This patch add a new aspect Lock_Free that turns on/off the lock-free
implementation of protected objects. It also creates a new flag Uses_Lock_Free
which is present only in protected type entities. Four different modes of the
lock-free implementation can be distinguished:

* Full:
  Lock_Free aspect is True and the protected object satisfies all the lock-free
  restrictions. In this case, both the declaration and the body of the object
  are expanded in the lock-free manner.

* Partial:
  No Lock_Free aspect and the protected object satisfies all the lock-free
  restrictions. In this case, only the body of the object is expanded in the
  lock-free manner.

* Posted:
  Lock_Free aspect is True but the protected object doesn't satisfy all the
  lock-free restrictions. In this case, an error message is issued.

* Off:
  Lock_Free aspect is False or all the restrictions are met. In this case, the
  usual implementation of protected object is used.

The test provided below illustrates the expanded code generated by the full
lock-free implementation of a simple protected object.

------------
-- Source --
------------

procedure Main is

   protected type Shared_Int
     with Lock_Free
   is
      function Value return Integer;

      procedure Add (N : in Integer);

   private
      Obj : Integer := 0;
   end Shared_Int;

   protected body Shared_Int is

      function Value return Integer is
      begin
         return Obj;
      end Value;

      procedure Add (N : in Integer) is
      begin
         Obj := Obj + N;
      end Add;

   end Shared_Int;

begin
   null;
end Main;

-----------------
-- Compilation --
-----------------

gnatmake -f -gnat12 -gnatDG main.adb

-------------------
-- Expanded code --
-------------------

with system.system__atomic_primitives;
with system;

procedure main is
   protected type main__shared_int is
      function main__shared_int__value return integer;
      procedure main__shared_int__add (n : in integer);
   private
      main__shared_int__obj : integer := 0;
   end main__shared_int
     with lock_free;
   type main__shared_intV is limited record
      obj : integer := 0;
   end record;
   function main__shared_int__valueN (_object : in main__shared_intV)
     return integer;
   function main__shared_int__valueP (_object : in main__shared_intV)
     return integer;
   procedure main__shared_int__addN (_object : in out main__shared_intV;
     n : in integer);
   procedure main__shared_int__addP (_object : in out main__shared_intV;
     n : in integer);
   freeze main__shared_intV [
      procedure main__shared_intVIP (_init : in out main__shared_intV) is
      begin
         _init.obj := 0;
         return;
      end main__shared_intVIP;
   ]
   freeze main__shared_int []
   freeze main__shared_int__valueN []
   freeze main__shared_int__valueP []
   freeze main__shared_int__addN []
   freeze main__shared_int__addP []
   null;
   freeze main__shared_int__value []

   function main__shared_int__valueN (_object : in main__shared_intV)
     return integer is
      obj : integer renames _object.obj;
      obj___XR__object___XEXRobj : _renaming_type;
      obj_saved : constant integer := integer!(
        $system__atomic_primitives__atomic_load_32 (obj'address, model =>
        5));
   begin
      return obj_saved;
   end main__shared_int__valueN;

   function main__shared_int__valueP (_object : in main__shared_intV)
     return integer is
   begin
      return main__shared_int__valueN (_object);
   end main__shared_int__valueP;

   procedure main__shared_int__addN (_object : in out main__shared_intV;
     n : in integer) is
      obj : integer renames _object.obj;
      obj___XR__object___XEXRobj : _renaming_type;
   begin
      $system__atomic_primitives__atomic_synchronize;
      loop
         L4b__B5b : declare
            obj_saved : constant integer := integer!(
              $system__atomic_primitives__atomic_load_32 (obj'address,
              0));
            obj_current : integer := obj_saved;
         begin
            obj_current := obj_current + n;
            exit when
              $system__atomic_primitives__atomic_compare_exchange_32 (
              obj'address, system__atomic_primitives__uint32!(obj_saved),
              system__atomic_primitives__uint32!(obj_current));
         end L4b__B5b;
      end loop;
      return;
   end main__shared_int__addN;

   procedure main__shared_int__addP (_object : in out main__shared_intV;
     n : in integer) is
   begin
      main__shared_int__addN (_object, n);
      return;
   end main__shared_int__addP;
begin
   null;
   return;
end main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-05-15  Vincent Pucci  <pucci@adacore.com>

	* aspects.adb, aspects.adb: Reordering of the Aspect_Idi list. New
	aspect Aspect_Lock_Free.
	* einfo.adb, einfo.ads: New flag Uses_Lock_Free (flag 188).
	(Set_Uses_Lock_Free): New routine.
	(Uses_Lock_Free): New routine.
	* exp_ch7.adb (Is_Simple_Protected_Type): Return False for
	lock-free implementation.
	* exp_ch9.adb (Allows_Lock_Free_Implementation): Moved to Sem_Ch9.
	(Build_Lock_Free_Unprotected_Subprogram_Body): Protected
	procedure uses __sync_synchronise. Check both Object_Size
	and Value_Size.
	(Expand_N_Protected_Body): Lock_Free_Active
	renames Lock_Free_On.
	(Expand_N_Protected_Type_Declaration):
	_Object field removed for lock-free implementation.
	(Install_Private_Data_Declarations): Protection object removed
	for lock-free implementation.
	(Make_Initialize_Protection):
	Protection object initialization removed for lock-free implementation.
	* rtsfind.ads: RE_Atomic_Synchronize and RE_Relaxed added.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Aspect_Lock_Free
	analysis added.
	* sem_ch9.adb (Allows_Lock_Free_Implementation): New routine.
	(Analyze_Protected_Body): Allows_Lock_Free_Implementation call added.
	(Analyze_Protected_Type_Declaration):
	Allows_Lock_Free_Implementation call added.
	(Analyze_Single_Protected_Declaration): Second analysis of
	aspects removed.
	* s-atopri.ads: Header added.
	(Atomic_Synchronize): New routine.

Patch

Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 187501)
+++ exp_ch7.adb	(working copy)
@@ -4602,6 +4602,7 @@ 
    begin
       return
         Is_Protected_Type (T)
+          and then not Uses_Lock_Free (T)
           and then not Has_Entries (T)
           and then Is_RTE (Find_Protection_Type (T), RE_Protection);
    end Is_Simple_Protected_Type;
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb	(revision 187501)
+++ exp_ch9.adb	(working copy)
@@ -25,7 +25,6 @@ 
 
 with Atree;    use Atree;
 with Checks;   use Checks;
-with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
@@ -52,6 +51,7 @@ 
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Ch9;  use Sem_Ch9;
 with Sem_Ch11; use Sem_Ch11;
 with Sem_Elab; use Sem_Elab;
 with Sem_Eval; use Sem_Eval;
@@ -61,7 +61,6 @@ 
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
-with Table;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
@@ -77,37 +76,6 @@ 
 
    Entry_Family_Bound : constant Int := 2**16;
 
-   ------------------------------
-   -- Lock Free Data Structure --
-   ------------------------------
-
-   --  A lock-free subprogram is a protected routine which references a unique
-   --  protected scalar component and does not contain statements that cause
-   --  side effects. Due to this restricted behavior, all references to shared
-   --  data from within the subprogram can be synchronized through the use of
-   --  atomic operations rather than relying on locks.
-
-   type Lock_Free_Subprogram is record
-      Sub_Body : Node_Id;
-      --  Reference to the body of a protected subprogram which meets the lock-
-      --  free requirements.
-
-      Comp_Id : Entity_Id;
-      --  Reference to the scalar component referenced from within Sub_Body
-   end record;
-
-   --  This table establishes a relation between a protected subprogram body
-   --  and a unique component it references. The table is used when building
-   --  the lock-free versions of a protected subprogram body.
-
-   package Lock_Free_Subprogram_Table is new Table.Table (
-     Table_Component_Type => Lock_Free_Subprogram,
-     Table_Index_Type     => Nat,
-     Table_Low_Bound      => 1,
-     Table_Initial        => 5,
-     Table_Increment      => 5,
-     Table_Name           => "Lock_Free_Subprogram_Table");
-
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -142,20 +110,6 @@ 
    --    Decls is the list of declarations to be enhanced.
    --    Ent is the entity for the original entry body.
 
-   function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean;
-   --  Given a protected body N, return True if N satisfies the following list
-   --  of lock-free restrictions:
-   --
-   --    1) Protected type
-   --         May not contain entries
-   --         May contain only scalar components
-   --         Component types must support atomic compare and exchange
-   --
-   --    2) Protected subprograms
-   --         May not have side effects
-   --         May not contain loop statements or procedure calls
-   --         Function calls and attribute references must be static
-
    function Build_Accept_Body (Astat : Node_Id) return Node_Id;
    --  Transform accept statement into a block with added exception handler.
    --  Used both for simple accept statements and for accept alternatives in
@@ -828,220 +782,6 @@ 
       Prepend_To (Decls, Decl);
    end Add_Object_Pointer;
 
-   -------------------------------------
-   -- Allows_Lock_Free_Implementation --
-   -------------------------------------
-
-   function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean is
-      Spec       : constant Entity_Id := Corresponding_Spec (N);
-      Prot_Def   : constant Node_Id   := Protected_Definition (Parent (Spec));
-      Priv_Decls : constant List_Id   := Private_Declarations (Prot_Def);
-
-      function Satisfies_Lock_Free_Requirements
-        (Sub_Body : Node_Id) return Boolean;
-      --  Return True if protected subprogram body Sub_Body satisfies all
-      --  requirements of a lock-free implementation.
-
-      --------------------------------------
-      -- Satisfies_Lock_Free_Requirements --
-      --------------------------------------
-
-      function Satisfies_Lock_Free_Requirements
-        (Sub_Body : Node_Id) return Boolean
-      is
-         Comp : Entity_Id := Empty;
-         --  Track the current component which the body references
-
-         function Check_Node (N : Node_Id) return Traverse_Result;
-         --  Check that node N meets the lock free restrictions
-
-         ----------------
-         -- Check_Node --
-         ----------------
-
-         function Check_Node (N : Node_Id) return Traverse_Result is
-         begin
-            --  Function calls and attribute references must be static
-            --  ??? what about side-effects
-
-            if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
-              and then not Is_Static_Expression (N)
-            then
-               return Abandon;
-
-            --  Loop statements and procedure calls are prohibited
-
-            elsif Nkind_In (N, N_Loop_Statement,
-                               N_Procedure_Call_Statement)
-            then
-               return Abandon;
-
-            --  References
-
-            elsif Nkind (N) = N_Identifier
-              and then Present (Entity (N))
-            then
-               declare
-                  Id     : constant Entity_Id := Entity (N);
-                  Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body);
-
-               begin
-                  --  Prohibit references to non-constant entities outside the
-                  --  protected subprogram scope.
-
-                  if Ekind (Id) in Assignable_Kind
-                    and then not Scope_Within_Or_Same (Scope (Id), Sub_Id)
-                    and then not Scope_Within_Or_Same (Scope (Id),
-                                   Protected_Body_Subprogram (Sub_Id))
-                  then
-                     return Abandon;
-
-                  --  A protected subprogram may reference only one component
-                  --  of the protected type.
-
-                  elsif Ekind_In (Id, E_Constant, E_Variable)
-                    and then Present (Prival_Link (Id))
-                  then
-                     declare
-                        Comp_Decl : constant Node_Id :=
-                                      Parent (Prival_Link (Id));
-                     begin
-                        if Nkind (Comp_Decl) = N_Component_Declaration
-                          and then Is_List_Member (Comp_Decl)
-                          and then List_Containing (Comp_Decl) = Priv_Decls
-                        then
-                           if No (Comp) then
-                              Comp := Prival_Link (Id);
-
-                           --  Check if another protected component has already
-                           --  been accessed by the subprogram body.
-
-                           elsif Comp /= Prival_Link (Id) then
-                              return Abandon;
-                           end if;
-                        end if;
-                     end;
-                  end if;
-               end;
-            end if;
-
-            return OK;
-         end Check_Node;
-
-         function Check_All_Nodes is new Traverse_Func (Check_Node);
-
-      --  Start of processing for Satisfies_Lock_Free_Requirements
-
-      begin
-         if Check_All_Nodes (Sub_Body) = OK then
-
-            --  Establish a relation between the subprogram body and the unique
-            --  protected component it references.
-
-            if Present (Comp) then
-               Lock_Free_Subprogram_Table.Append
-                 (Lock_Free_Subprogram'(Sub_Body, Comp));
-            end if;
-
-            return True;
-         else
-            return False;
-         end if;
-      end Satisfies_Lock_Free_Requirements;
-
-      --  Local variables
-
-      Decls     : constant List_Id   := Declarations (N);
-      Vis_Decls : constant List_Id   := Visible_Declarations (Prot_Def);
-
-      Comp_Id       : Entity_Id;
-      Comp_Size     : Int;
-      Comp_Type     : Entity_Id;
-      Decl          : Node_Id;
-      Has_Component : Boolean := False;
-
-   --  Start of processing for Allows_Lock_Free_Implementation
-
-   begin
-      --  The lock-free implementation is currently enabled through a debug
-      --  flag.
-
-      if not Debug_Flag_9 then
-         return False;
-      end if;
-
-      --  Examine the visible declarations. Entries and entry families are not
-      --  allowed by the lock-free restrictions.
-
-      Decl := First (Vis_Decls);
-      while Present (Decl) loop
-         if Nkind (Decl) = N_Entry_Declaration then
-            return False;
-         end if;
-
-         Next (Decl);
-      end loop;
-
-      --  Examine the private declarations
-
-      Decl := First (Priv_Decls);
-      while Present (Decl) loop
-
-         --  The protected type must define at least one scalar component
-
-         if Nkind (Decl) = N_Component_Declaration then
-            Has_Component := True;
-
-            Comp_Id   := Defining_Identifier (Decl);
-            Comp_Type := Etype (Comp_Id);
-
-            if not Is_Scalar_Type (Comp_Type) then
-               return False;
-            end if;
-
-            Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type)));
-
-            --  Check that the size of the component is 8, 16, 32 or 64 bits
-
-            case Comp_Size is
-               when 8 | 16 | 32 | 64 =>
-                  null;
-               when others           =>
-                  return False;
-            end case;
-
-         --  Entries and entry families are not allowed
-
-         elsif Nkind (Decl) = N_Entry_Declaration then
-            return False;
-         end if;
-
-         Next (Decl);
-      end loop;
-
-      --  At least one scalar component must be present
-
-      if not Has_Component then
-         return False;
-      end if;
-
-      --  Ensure that all protected subprograms meet the restrictions of the
-      --  lock-free implementation.
-
-      Decl := First (Decls);
-      while Present (Decl) loop
-         if Nkind (Decl) = N_Subprogram_Body
-           and then not Satisfies_Lock_Free_Requirements (Decl)
-         then
-            return False;
-         end if;
-
-         Next (Decl);
-      end loop;
-
-      return True;
-   end Allows_Lock_Free_Implementation;
-
    -----------------------
    -- Build_Accept_Body --
    -----------------------
@@ -3228,7 +2968,8 @@ 
    --    begin
    --       loop
    --          declare
-   --             Saved_Comp   : constant ... := Atomic_Load (Comp'Address);
+   --             Saved_Comp   : constant ... :=
+   --                              Atomic_Load (Comp'Address, Relaxed);
    --             Current_Comp : ... := Saved_Comp;
    --          begin
    --             <original statements>
@@ -3496,19 +3237,33 @@ 
 
       if Present (Comp) then
          declare
-            Comp_Typ     : constant Entity_Id := Etype (Comp);
-            Typ_Size     : constant Int       := UI_To_Int (Esize (Comp_Typ));
+            Comp_Type    : constant Entity_Id := Etype (Comp);
             Block_Decls  : List_Id;
             Compare      : Entity_Id;
             Current_Comp : Entity_Id;
             Decl         : Node_Id;
             Label        : Node_Id;
             Load         : Entity_Id;
+            Load_Params  : List_Id;
             Saved_Comp   : Entity_Id;
             Stmt         : Node_Id;
+            Typ_Size     : Int;
             Unsigned     : Entity_Id;
 
          begin
+            --  Get the type size
+
+            if Known_Esize (Comp_Type) then
+               Typ_Size := UI_To_Int (Esize (Comp_Type));
+
+            --  If the Esize (Object_Size) is unknown at compile-time, look at
+            --  the RM_Size (Value_Size) since it may have been set by an
+            --  explicit representation clause.
+
+            else
+               Typ_Size := UI_To_Int (RM_Size (Comp_Type));
+            end if;
+
             --  Retrieve all relevant atomic routines and types
 
             case Typ_Size is
@@ -3537,26 +3292,43 @@ 
             end case;
 
             --  Generate:
-            --    Saved_Comp : constant Comp_Typ :=
-            --                   Comp_Typ (Atomic_Load (Comp'Address));
+            --    For functions:
 
+            --       Saved_Comp : constant Comp_Type :=
+            --                      Comp_Type (Atomic_Load (Comp'Address));
+
+            --    For procedures:
+
+            --       Saved_Comp : constant Comp_Type :=
+            --                      Comp_Type (Atomic_Load (Comp'Address),
+            --                                             Relaxed);
+
             Saved_Comp :=
               Make_Defining_Identifier (Loc,
                 New_External_Name (Chars (Comp), Suffix => "_saved"));
 
+            Load_Params := New_List (
+              Make_Attribute_Reference (Loc,
+                Prefix         => New_Reference_To (Comp, Loc),
+                Attribute_Name => Name_Address));
+
+            --  For protected procedures, set the memory model to be relaxed
+
+            if Is_Procedure then
+               Append_To (Load_Params,
+                 New_Reference_To (RTE (RE_Relaxed), Loc));
+            end if;
+
             Decl :=
               Make_Object_Declaration (Loc,
                 Defining_Identifier => Saved_Comp,
                 Constant_Present    => True,
-                Object_Definition   => New_Reference_To (Comp_Typ, Loc),
+                Object_Definition   => New_Reference_To (Comp_Type, Loc),
                 Expression          =>
-                  Unchecked_Convert_To (Comp_Typ,
+                  Unchecked_Convert_To (Comp_Type,
                     Make_Function_Call (Loc,
                       Name                   => New_Reference_To (Load, Loc),
-                      Parameter_Associations => New_List (
-                        Make_Attribute_Reference (Loc,
-                          Prefix         => New_Reference_To (Comp, Loc),
-                          Attribute_Name => Name_Address)))));
+                      Parameter_Associations => Load_Params)));
 
             --  Protected procedures
 
@@ -3564,7 +3336,7 @@ 
                Block_Decls := New_List (Decl);
 
                --  Generate:
-               --    Current_Comp : Comp_Typ := Saved_Comp;
+               --    Current_Comp : Comp_Type := Saved_Comp;
 
                Current_Comp :=
                  Make_Defining_Identifier (Loc,
@@ -3573,7 +3345,7 @@ 
                Append_To (Block_Decls,
                  Make_Object_Declaration (Loc,
                    Defining_Identifier => Current_Comp,
-                   Object_Definition   => New_Reference_To (Comp_Typ, Loc),
+                   Object_Definition   => New_Reference_To (Comp_Type, Loc),
                    Expression          => New_Reference_To (Saved_Comp, Loc)));
 
             --  Protected function
@@ -3645,6 +3417,9 @@ 
 
             if Is_Procedure then
                Stmts := New_List (
+                Make_Procedure_Call_Statement (Loc,
+                    Name =>
+                      New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)),
                  Make_Loop_Statement (Loc,
                    Statements => New_List (
                      Make_Block_Statement (Loc,
@@ -8423,7 +8198,7 @@ 
       Loc          : constant Source_Ptr := Sloc (N);
       Pid          : constant Entity_Id  := Corresponding_Spec (N);
 
-      Lock_Free_On : constant Boolean := Allows_Lock_Free_Implementation (N);
+      Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid);
       --  This flag indicates whether the lock free implementation is active
 
       Current_Node : Node_Id;
@@ -8554,7 +8329,7 @@ 
                if not Is_Eliminated (Defining_Entity (Op_Body))
                  and then not Is_Eliminated (Corresponding_Spec (Op_Body))
                then
-                  if Lock_Free_On then
+                  if Lock_Free_Active then
                      New_Op_Body :=
                        Build_Lock_Free_Unprotected_Subprogram_Body
                          (Op_Body, Pid);
@@ -8581,7 +8356,7 @@ 
                   --  declaration in the protected body itself.
 
                   if Present (Corresponding_Spec (Op_Body)) then
-                     if Lock_Free_On then
+                     if Lock_Free_Active then
                         New_Op_Body :=
                           Build_Lock_Free_Protected_Subprogram_Body
                             (Op_Body, Pid, Specification (New_Op_Body));
@@ -8765,10 +8540,13 @@ 
    --  the specs refer to this type.
 
    procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
-      Loc      : constant Source_Ptr := Sloc (N);
-      Prot_Typ : constant Entity_Id  := Defining_Identifier (N);
+      Loc              : constant Source_Ptr := Sloc (N);
+      Prot_Typ         : constant Entity_Id  := Defining_Identifier (N);
 
-      Pdef : constant Node_Id := Protected_Definition (N);
+      Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ);
+      --  This flag indicates whether the lock free implementation is active
+
+      Pdef             : constant Node_Id := Protected_Definition (N);
       --  This contains two lists; one for visible and one for private decls
 
       Rec_Decl     : Node_Id;
@@ -8926,108 +8704,6 @@ 
 
       Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ);
 
-      --  Prepend the _Object field with the right type to the component list.
-      --  We need to compute the number of entries, and in some cases the
-      --  number of Attach_Handler pragmas.
-
-      declare
-         Ritem              : Node_Id;
-         Num_Attach_Handler : Int := 0;
-         Protection_Subtype : Node_Id;
-         Entry_Count_Expr   : constant Node_Id :=
-                                Build_Entry_Count_Expression
-                                  (Prot_Typ, Cdecls, Loc);
-
-      begin
-         --  Could this be simplified using Corresponding_Runtime_Package???
-
-         if Has_Attach_Handler (Prot_Typ) then
-            Ritem := First_Rep_Item (Prot_Typ);
-            while Present (Ritem) loop
-               if Nkind (Ritem) = N_Pragma
-                 and then Pragma_Name (Ritem) = Name_Attach_Handler
-               then
-                  Num_Attach_Handler := Num_Attach_Handler + 1;
-               end if;
-
-               Next_Rep_Item (Ritem);
-            end loop;
-
-            if Restricted_Profile then
-               if Has_Entries (Prot_Typ) then
-                  Protection_Subtype :=
-                    New_Reference_To (RTE (RE_Protection_Entry), Loc);
-               else
-                  Protection_Subtype :=
-                    New_Reference_To (RTE (RE_Protection), Loc);
-               end if;
-            else
-               Protection_Subtype :=
-                 Make_Subtype_Indication
-                   (Sloc => Loc,
-                    Subtype_Mark =>
-                      New_Reference_To
-                        (RTE (RE_Static_Interrupt_Protection), Loc),
-                    Constraint =>
-                      Make_Index_Or_Discriminant_Constraint (
-                        Sloc => Loc,
-                        Constraints => New_List (
-                          Entry_Count_Expr,
-                          Make_Integer_Literal (Loc, Num_Attach_Handler))));
-            end if;
-
-         elsif Has_Interrupt_Handler (Prot_Typ)
-           and then not Restriction_Active (No_Dynamic_Attachment)
-         then
-            Protection_Subtype :=
-               Make_Subtype_Indication (
-                 Sloc => Loc,
-                 Subtype_Mark => New_Reference_To
-                   (RTE (RE_Dynamic_Interrupt_Protection), Loc),
-                 Constraint =>
-                   Make_Index_Or_Discriminant_Constraint (
-                     Sloc => Loc,
-                     Constraints => New_List (Entry_Count_Expr)));
-
-         --  Type has explicit entries or generated primitive entry wrappers
-
-         elsif Has_Entries (Prot_Typ)
-           or else (Ada_Version >= Ada_2005
-                      and then Present (Interface_List (N)))
-         then
-            case Corresponding_Runtime_Package (Prot_Typ) is
-               when System_Tasking_Protected_Objects_Entries =>
-                  Protection_Subtype :=
-                     Make_Subtype_Indication (Loc,
-                       Subtype_Mark =>
-                         New_Reference_To (RTE (RE_Protection_Entries), Loc),
-                       Constraint =>
-                         Make_Index_Or_Discriminant_Constraint (
-                           Sloc => Loc,
-                           Constraints => New_List (Entry_Count_Expr)));
-
-               when System_Tasking_Protected_Objects_Single_Entry =>
-                  Protection_Subtype :=
-                    New_Reference_To (RTE (RE_Protection_Entry), Loc);
-
-               when others =>
-                  raise Program_Error;
-            end case;
-
-         else
-            Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc);
-         end if;
-
-         Object_Comp :=
-           Make_Component_Declaration (Loc,
-             Defining_Identifier =>
-               Make_Defining_Identifier (Loc, Name_uObject),
-             Component_Definition =>
-               Make_Component_Definition (Loc,
-                 Aliased_Present    => True,
-                 Subtype_Indication => Protection_Subtype));
-      end;
-
       pragma Assert (Present (Pdef));
 
       --  Add private field components
@@ -9144,11 +8820,118 @@ 
          end loop;
       end if;
 
-      --  Put the _Object component after the private component so that it
-      --  be finalized early as required by 9.4 (20)
+      --  Except for the lock-free implementation, prepend the _Object field
+      --  with the right type to the component list. We need to compute the
+      --  number of entries, and in some cases the number of Attach_Handler
+      --  pragmas.
 
-      Append_To (Cdecls, Object_Comp);
+      if not Lock_Free_Active then
+         declare
+            Ritem              : Node_Id;
+            Num_Attach_Handler : Int := 0;
+            Protection_Subtype : Node_Id;
+            Entry_Count_Expr   : constant Node_Id :=
+                                   Build_Entry_Count_Expression
+                                     (Prot_Typ, Cdecls, Loc);
 
+         begin
+            --  Could this be simplified using Corresponding_Runtime_Package???
+
+            if Has_Attach_Handler (Prot_Typ) then
+               Ritem := First_Rep_Item (Prot_Typ);
+               while Present (Ritem) loop
+                  if Nkind (Ritem) = N_Pragma
+                    and then Pragma_Name (Ritem) = Name_Attach_Handler
+                  then
+                     Num_Attach_Handler := Num_Attach_Handler + 1;
+                  end if;
+
+                  Next_Rep_Item (Ritem);
+               end loop;
+
+               if Restricted_Profile then
+                  if Has_Entries (Prot_Typ) then
+                     Protection_Subtype :=
+                       New_Reference_To (RTE (RE_Protection_Entry), Loc);
+                  else
+                     Protection_Subtype :=
+                       New_Reference_To (RTE (RE_Protection), Loc);
+                  end if;
+               else
+                  Protection_Subtype :=
+                    Make_Subtype_Indication
+                      (Sloc => Loc,
+                       Subtype_Mark =>
+                         New_Reference_To
+                           (RTE (RE_Static_Interrupt_Protection), Loc),
+                       Constraint =>
+                         Make_Index_Or_Discriminant_Constraint (
+                           Sloc => Loc,
+                           Constraints => New_List (
+                             Entry_Count_Expr,
+                             Make_Integer_Literal (Loc, Num_Attach_Handler))));
+               end if;
+
+            elsif Has_Interrupt_Handler (Prot_Typ)
+              and then not Restriction_Active (No_Dynamic_Attachment)
+            then
+               Protection_Subtype :=
+                  Make_Subtype_Indication (
+                    Sloc => Loc,
+                    Subtype_Mark => New_Reference_To
+                      (RTE (RE_Dynamic_Interrupt_Protection), Loc),
+                    Constraint =>
+                      Make_Index_Or_Discriminant_Constraint (
+                        Sloc => Loc,
+                        Constraints => New_List (Entry_Count_Expr)));
+
+            --  Type has explicit entries or generated primitive entry wrappers
+
+            elsif Has_Entries (Prot_Typ)
+              or else (Ada_Version >= Ada_2005
+                         and then Present (Interface_List (N)))
+            then
+               case Corresponding_Runtime_Package (Prot_Typ) is
+                  when System_Tasking_Protected_Objects_Entries =>
+                     Protection_Subtype :=
+                        Make_Subtype_Indication (Loc,
+                          Subtype_Mark =>
+                            New_Reference_To (RTE (RE_Protection_Entries),
+                              Loc),
+                          Constraint =>
+                            Make_Index_Or_Discriminant_Constraint (
+                              Sloc => Loc,
+                              Constraints => New_List (Entry_Count_Expr)));
+
+                  when System_Tasking_Protected_Objects_Single_Entry =>
+                     Protection_Subtype :=
+                       New_Reference_To (RTE (RE_Protection_Entry), Loc);
+
+                  when others =>
+                     raise Program_Error;
+               end case;
+
+            else
+               Protection_Subtype :=
+                 New_Reference_To (RTE (RE_Protection), Loc);
+            end if;
+
+            Object_Comp :=
+              Make_Component_Declaration (Loc,
+                Defining_Identifier =>
+                  Make_Defining_Identifier (Loc, Name_uObject),
+                Component_Definition =>
+                  Make_Component_Definition (Loc,
+                    Aliased_Present    => True,
+                    Subtype_Indication => Protection_Subtype));
+         end;
+
+         --  Put the _Object component after the private component so that it
+         --  be finalized early as required by 9.4 (20)
+
+         Append_To (Cdecls, Object_Comp);
+      end if;
+
       Insert_After (Current_Node, Rec_Decl);
       Current_Node := Rec_Decl;
 
@@ -13149,9 +12932,12 @@ 
       end if;
 
       --  Step 2: Create the Protection object and build its declaration for
-      --  any protected entry (family) of subprogram.
+      --  any protected entry (family) of subprogram. Note for the lock-free
+      --  implementation, the Protection object is not needed anymore.
 
-      if Is_Protected then
+      if Is_Protected
+        and then not Uses_Lock_Free (Conc_Typ)
+      then
          declare
             Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R');
             Prot_Typ : RE_Id;
@@ -13612,191 +13398,200 @@ 
 
       Args := New_List;
 
-      --  Object parameter. This is a pointer to the object of type
-      --  Protection used by the GNARL to control the protected object.
+      --  For lock-free implementation, skip initializations of the Protection
+      --  object.
 
-      Append_To (Args,
-        Make_Attribute_Reference (Loc,
-          Prefix =>
-            Make_Selected_Component (Loc,
-              Prefix        => Make_Identifier (Loc, Name_uInit),
-              Selector_Name => Make_Identifier (Loc, Name_uObject)),
-          Attribute_Name => Name_Unchecked_Access));
+      if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
+         --  Object parameter. This is a pointer to the object of type
+         --  Protection used by the GNARL to control the protected object.
 
-      --  Priority parameter. Set to Unspecified_Priority unless there is a
-      --  priority pragma, in which case we take the value from the pragma,
-      --  or there is an interrupt pragma and no priority pragma, and we
-      --  set the ceiling to Interrupt_Priority'Last, an implementation-
-      --  defined value, see D.3(10).
+         Append_To (Args,
+           Make_Attribute_Reference (Loc,
+             Prefix =>
+               Make_Selected_Component (Loc,
+                 Prefix        => Make_Identifier (Loc, Name_uInit),
+                 Selector_Name => Make_Identifier (Loc, Name_uObject)),
+             Attribute_Name => Name_Unchecked_Access));
 
-      if Present (Pdef)
-        and then Has_Pragma_Priority (Pdef)
-      then
-         declare
-            Prio : constant Node_Id :=
-                     Expression
-                       (First
-                          (Pragma_Argument_Associations
-                             (Find_Task_Or_Protected_Pragma
-                                (Pdef, Name_Priority))));
-            Temp : Entity_Id;
+         --  Priority parameter. Set to Unspecified_Priority unless there is a
+         --  priority pragma, in which case we take the value from the pragma,
+         --  or there is an interrupt pragma and no priority pragma, and we
+         --  set the ceiling to Interrupt_Priority'Last, an implementation-
+         --  defined value, see D.3(10).
 
-         begin
-            --  If priority is a static expression, then we can duplicate it
-            --  with no problem and simply append it to the argument list.
+         if Present (Pdef)
+           and then Has_Pragma_Priority (Pdef)
+         then
+            declare
+               Prio : constant Node_Id :=
+                        Expression
+                          (First
+                             (Pragma_Argument_Associations
+                                (Find_Task_Or_Protected_Pragma
+                                   (Pdef, Name_Priority))));
+               Temp : Entity_Id;
 
-            if Is_Static_Expression (Prio) then
-               Append_To (Args,
-                          Duplicate_Subexpr_No_Checks (Prio));
+            begin
+               --  If priority is a static expression, then we can duplicate it
+               --  with no problem and simply append it to the argument list.
 
-            --  Otherwise, the priority may be a per-object expression, if it
-            --  depends on a discriminant of the type. In this case, create
-            --  local variable to capture the expression. Note that it is
-            --  really necessary to create this variable explicitly. It might
-            --  be thought that removing side effects would the appropriate
-            --  approach, but that could generate declarations improperly
-            --  placed in the enclosing scope.
+               if Is_Static_Expression (Prio) then
+                  Append_To (Args,
+                    Duplicate_Subexpr_No_Checks (Prio));
 
-            --  Note: Use System.Any_Priority as the expected type for the
-            --  non-static priority expression, in case the expression has not
-            --  been analyzed yet (as occurs for example with pragma
-            --  Interrupt_Priority).
+               --  Otherwise, the priority may be a per-object expression, if
+               --  it depends on a discriminant of the type. In this case,
+               --  create local variable to capture the expression. Note that
+               --  it is really necessary to create this variable explicitly.
+               --  It might be thought that removing side effects would the
+               --  appropriate approach, but that could generate declarations
+               --  improperly placed in the enclosing scope.
 
-            else
-               Temp := Make_Temporary (Loc, 'R', Prio);
-               Append_To (L,
-                  Make_Object_Declaration (Loc,
-                     Defining_Identifier => Temp,
-                     Object_Definition   =>
-                       New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
-                     Expression          => Relocate_Node (Prio)));
+               --  Note: Use System.Any_Priority as the expected type for the
+               --  non-static priority expression, in case the expression has
+               --  not been analyzed yet (as occurs for example with pragma
+               --  Interrupt_Priority).
 
-               Append_To (Args, New_Occurrence_Of (Temp, Loc));
-            end if;
-         end;
+               else
+                  Temp := Make_Temporary (Loc, 'R', Prio);
+                  Append_To (L,
+                     Make_Object_Declaration (Loc,
+                        Defining_Identifier => Temp,
+                        Object_Definition   =>
+                          New_Occurrence_Of (RTE (RE_Any_Priority), Loc),
+                        Expression          => Relocate_Node (Prio)));
 
-      --  When no priority is specified but an xx_Handler pragma is, we default
-      --  to System.Interrupts.Default_Interrupt_Priority, see D.3(10).
+                  Append_To (Args, New_Occurrence_Of (Temp, Loc));
+               end if;
+            end;
 
-      elsif Has_Attach_Handler (Ptyp)
-        or else Has_Interrupt_Handler (Ptyp)
-      then
-         Append_To (Args,
-           New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
+         --  When no priority is specified but an xx_Handler pragma is, we
+         --  default to System.Interrupts.Default_Interrupt_Priority, see
+         --  D.3(10).
 
-      --  Normal case, no priority or xx_Handler specified, default priority
+         elsif Has_Attach_Handler (Ptyp)
+           or else Has_Interrupt_Handler (Ptyp)
+         then
+            Append_To (Args,
+              New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc));
 
-      else
-         Append_To (Args,
-           New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
-      end if;
+         --  Normal case, no priority or xx_Handler specified, default priority
 
-      --  Test for Compiler_Info parameter. This parameter allows entry body
-      --  procedures and barrier functions to be called from the runtime. It
-      --  is a pointer to the record generated by the compiler to represent
-      --  the protected object.
+         else
+            Append_To (Args,
+              New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
+         end if;
 
-      --  A protected type without entries that covers an interface and
-      --  overrides the abstract routines with protected procedures is
-      --  considered equivalent to a protected type with entries in the
-      --  context of dispatching select statements.
+         --  Test for Compiler_Info parameter. This parameter allows entry body
+         --  procedures and barrier functions to be called from the runtime. It
+         --  is a pointer to the record generated by the compiler to represent
+         --  the protected object.
 
-      if Has_Entry
-        or else Has_Interfaces (Protect_Rec)
-        or else
-          ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
-             and then not Restriction_Active (No_Dynamic_Attachment))
-      then
-         declare
-            Pkg_Id : constant RTU_Id  := Corresponding_Runtime_Package (Ptyp);
+         --  A protected type without entries that covers an interface and
+         --  overrides the abstract routines with protected procedures is
+         --  considered equivalent to a protected type with entries in the
+         --  context of dispatching select statements.
 
-            Called_Subp : RE_Id;
+         if Has_Entry
+           or else Has_Interfaces (Protect_Rec)
+           or else
+             ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp))
+                and then not Restriction_Active (No_Dynamic_Attachment))
+         then
+            declare
+               Pkg_Id : constant RTU_Id  :=
+                          Corresponding_Runtime_Package (Ptyp);
 
-         begin
-            case Pkg_Id is
-               when System_Tasking_Protected_Objects_Entries =>
-                  Called_Subp := RE_Initialize_Protection_Entries;
+               Called_Subp : RE_Id;
 
-               when System_Tasking_Protected_Objects =>
-                  Called_Subp := RE_Initialize_Protection;
+            begin
+               case Pkg_Id is
+                  when System_Tasking_Protected_Objects_Entries =>
+                     Called_Subp := RE_Initialize_Protection_Entries;
 
-               when System_Tasking_Protected_Objects_Single_Entry =>
-                  Called_Subp := RE_Initialize_Protection_Entry;
+                  when System_Tasking_Protected_Objects =>
+                     Called_Subp := RE_Initialize_Protection;
 
-               when others =>
-                  raise Program_Error;
-            end case;
+                  when System_Tasking_Protected_Objects_Single_Entry =>
+                     Called_Subp := RE_Initialize_Protection_Entry;
 
-            if Has_Entry
-              or else not Restricted
-              or else Has_Interfaces (Protect_Rec)
-            then
-               Append_To (Args,
-                 Make_Attribute_Reference (Loc,
-                   Prefix         => Make_Identifier (Loc, Name_uInit),
-                   Attribute_Name => Name_Address));
-            end if;
+                  when others =>
+                     raise Program_Error;
+               end case;
 
-            --  Entry_Bodies parameter. This is a pointer to an array of
-            --  pointers to the entry body procedures and barrier functions of
-            --  the object. If the protected type has no entries this object
-            --  will not exist, in this case, pass a null.
+               if Has_Entry
+                 or else not Restricted
+                 or else Has_Interfaces (Protect_Rec)
+               then
+                  Append_To (Args,
+                    Make_Attribute_Reference (Loc,
+                      Prefix         => Make_Identifier (Loc, Name_uInit),
+                      Attribute_Name => Name_Address));
+               end if;
 
-            if Has_Entry then
-               P_Arr := Entry_Bodies_Array (Ptyp);
+               --  Entry_Bodies parameter. This is a pointer to an array of
+               --  pointers to the entry body procedures and barrier functions
+               --  of the object. If the protected type has no entries this
+               --  object will not exist, in this case, pass a null.
 
-               Append_To (Args,
-                 Make_Attribute_Reference (Loc,
-                   Prefix => New_Reference_To (P_Arr, Loc),
-                   Attribute_Name => Name_Unrestricted_Access));
+               if Has_Entry then
+                  P_Arr := Entry_Bodies_Array (Ptyp);
 
-               if Pkg_Id = System_Tasking_Protected_Objects_Entries then
-
-                  --  Find index mapping function (clumsy but ok for now)
-
-                  while Ekind (P_Arr) /= E_Function loop
-                     Next_Entity (P_Arr);
-                  end loop;
-
                   Append_To (Args,
                     Make_Attribute_Reference (Loc,
-                      Prefix         => New_Reference_To (P_Arr, Loc),
+                      Prefix => New_Reference_To (P_Arr, Loc),
                       Attribute_Name => Name_Unrestricted_Access));
 
-                  --  Build_Entry_Names generation flag. When set to true, the
-                  --  runtime will allocate an array to hold the string names
-                  --  of protected entries.
+                  if Pkg_Id = System_Tasking_Protected_Objects_Entries then
 
-                  if not Restricted_Profile then
-                     if Entry_Names_OK then
-                        Append_To (Args,
-                          New_Reference_To (Standard_True, Loc));
-                     else
-                        Append_To (Args,
-                          New_Reference_To (Standard_False, Loc));
+                     --  Find index mapping function (clumsy but ok for now)
+
+                     while Ekind (P_Arr) /= E_Function loop
+                        Next_Entity (P_Arr);
+                     end loop;
+
+                     Append_To (Args,
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (P_Arr, Loc),
+                         Attribute_Name => Name_Unrestricted_Access));
+
+                     --  Build_Entry_Names generation flag. When set to true,
+                     --  the runtime will allocate an array to hold the string
+                     --  names of protected entries.
+
+                     if not Restricted_Profile then
+                        if Entry_Names_OK then
+                           Append_To (Args,
+                             New_Reference_To (Standard_True, Loc));
+                        else
+                           Append_To (Args,
+                             New_Reference_To (Standard_False, Loc));
+                        end if;
                      end if;
                   end if;
-               end if;
 
-            elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then
-               Append_To (Args, Make_Null (Loc));
+               elsif Pkg_Id =
+                       System_Tasking_Protected_Objects_Single_Entry
+               then
+                  Append_To (Args, Make_Null (Loc));
 
-            elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
-               Append_To (Args, Make_Null (Loc));
-               Append_To (Args, Make_Null (Loc));
-               Append_To (Args, New_Reference_To (Standard_False, Loc));
-            end if;
+               elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
+                  Append_To (Args, Make_Null (Loc));
+                  Append_To (Args, Make_Null (Loc));
+                  Append_To (Args, New_Reference_To (Standard_False, Loc));
+               end if;
 
+               Append_To (L,
+                 Make_Procedure_Call_Statement (Loc,
+                   Name => New_Reference_To (RTE (Called_Subp), Loc),
+                   Parameter_Associations => Args));
+            end;
+         else
             Append_To (L,
               Make_Procedure_Call_Statement (Loc,
-                Name => New_Reference_To (RTE (Called_Subp), Loc),
+                Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
                 Parameter_Associations => Args));
-         end;
-      else
-         Append_To (L,
-           Make_Procedure_Call_Statement (Loc,
-             Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc),
-             Parameter_Associations => Args));
+         end if;
       end if;
 
       if Has_Attach_Handler (Ptyp) then
@@ -13868,15 +13663,18 @@ 
                    Parameter_Associations => Args));
 
             else
-               --  First, prepends the _object argument
+               if not Uses_Lock_Free (Defining_Identifier (Pdec)) then
+                  --  First, prepends the _object argument
 
-               Prepend_To (Args,
-                 Make_Attribute_Reference (Loc,
-                   Prefix =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => Make_Identifier (Loc, Name_uInit),
-                       Selector_Name => Make_Identifier (Loc, Name_uObject)),
-                   Attribute_Name => Name_Unchecked_Access));
+                  Prepend_To (Args,
+                    Make_Attribute_Reference (Loc,
+                      Prefix =>
+                        Make_Selected_Component (Loc,
+                          Prefix        => Make_Identifier (Loc, Name_uInit),
+                          Selector_Name =>
+                            Make_Identifier (Loc, Name_uObject)),
+                      Attribute_Name => Name_Unchecked_Access));
+               end if;
 
                --  Then, insert call to Install_Handlers
 
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 187501)
+++ sem_ch9.adb	(working copy)
@@ -23,13 +23,16 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
+with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Exp_Ch9;  use Exp_Ch9;
 with Elists;   use Elists;
 with Freeze;   use Freeze;
+with Layout;   use Layout;
 with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -64,6 +67,29 @@ 
    -- Local Subprograms --
    -----------------------
 
+   function Allows_Lock_Free_Implementation
+     (N        : Node_Id;
+      Complain : Boolean := False) return Boolean;
+   --  This dispatch routine return True if N satisfies the following list of
+   --  lock-free restrictions for protected type declaration and protected
+   --  body:
+   --
+   --    1) Protected type declaration
+   --         May not contain entries
+   --         Component types must support atomic compare and exchange
+   --
+   --    2) Protected Body
+   --         Each protected subprogram body within N must satisfy:
+   --            May reference only one protected component
+   --            May not reference non-constant entities outside the protected
+   --              subprogram scope.
+   --            May not reference non-scalar out parameters
+   --            May not contain loop statements or procedure calls
+   --            Function calls and attribute references must be static
+   --
+   --  If Complain is set to True, an error message is issued when return
+   --  False.
+
    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
    --  Given either a protected definition or a task definition in D, check
    --  the corresponding restriction parameter identifier R, and if it is set,
@@ -91,6 +117,304 @@ 
    --  Utility to make visible in corresponding body the entities defined in
    --  task, protected type declaration, or entry declaration.
 
+   -------------------------------------
+   -- Allows_Lock_Free_Implementation --
+   -------------------------------------
+
+   function Allows_Lock_Free_Implementation
+     (N        : Node_Id;
+      Complain : Boolean := False) return Boolean
+   is
+   begin
+      pragma Assert (Nkind_In (N,
+                               N_Protected_Type_Declaration,
+                               N_Protected_Body));
+
+      --  The lock-free implementation is currently enabled through a debug
+      --  flag. When Complain is True, an aspect Lock_Free forces the lock-free
+      --  implementation. In that case, the debug flag is not needed.
+
+      if not Complain
+        and then not Debug_Flag_9
+      then
+         return False;
+      end if;
+
+      --  Protected type declaration case
+
+      if Nkind (N) = N_Protected_Type_Declaration then
+         declare
+            Pdef       : constant Node_Id := Protected_Definition (N);
+            Priv_Decls : constant List_Id := Private_Declarations (Pdef);
+            Vis_Decls  : constant List_Id := Visible_Declarations (Pdef);
+
+            Comp_Id    : Entity_Id;
+            Comp_Size  : Int;
+            Comp_Type  : Entity_Id;
+            Decl       : Node_Id;
+
+         begin
+            --  Examine the visible declarations. Entries and entry families
+            --  are not allowed by the lock-free restrictions.
+
+            Decl := First (Vis_Decls);
+            while Present (Decl) loop
+               if Nkind (Decl) = N_Entry_Declaration then
+                  if Complain then
+                     Error_Msg_N ("entry not allowed for lock-free " &
+                                  "implementation",
+                                  Decl);
+                  end if;
+
+                  return False;
+               end if;
+
+               Next (Decl);
+            end loop;
+
+            --  Examine the private declarations
+
+            Decl := First (Priv_Decls);
+            while Present (Decl) loop
+
+               --  The protected type must define at least one scalar component
+
+               if Nkind (Decl) = N_Component_Declaration then
+                  Comp_Id       := Defining_Identifier (Decl);
+                  Comp_Type     := Etype (Comp_Id);
+
+                  --  Make sure the protected component type has size and
+                  --  alignment fields set at this point whenever this is
+                  --  possible.
+
+                  Layout_Type (Comp_Type);
+
+                  if Known_Esize (Comp_Type) then
+                     Comp_Size := UI_To_Int (Esize (Comp_Type));
+
+                  --  If the Esize (Object_Size) is unknown at compile-time,
+                  --  look at the RM_Size (Value_Size) since it may have been
+                  --  set by an explicit representation clause.
+
+                  else
+                     Comp_Size := UI_To_Int (RM_Size (Comp_Type));
+                  end if;
+
+                  --  Check that the size of the component is 8, 16, 32 or 64
+                  --  bits.
+
+                  case Comp_Size is
+                     when 8 | 16 | 32 | 64 =>
+                        null;
+                     when others           =>
+                        if Complain then
+                           Error_Msg_N ("must support atomic operations for " &
+                                        "lock-free implementation",
+                                         Decl);
+                        end if;
+
+                        return False;
+                  end case;
+
+               --  Entries and entry families are not allowed
+
+               elsif Nkind (Decl) = N_Entry_Declaration then
+                  if Complain then
+                     Error_Msg_N ("entry not allowed for lock-free " &
+                                  "implementation",
+                                  Decl);
+                  end if;
+
+                  return False;
+               end if;
+
+               Next (Decl);
+            end loop;
+         end;
+
+      --  Protected body case
+
+      else
+         declare
+            Decls         : constant List_Id   := Declarations (N);
+            Pid           : constant Entity_Id := Corresponding_Spec (N);
+            Prot_Typ_Decl : constant Node_Id   := Parent (Pid);
+            Prot_Def      : constant Node_Id   :=
+                              Protected_Definition (Prot_Typ_Decl);
+            Priv_Decls    : constant List_Id   :=
+                              Private_Declarations (Prot_Def);
+            Decl          : Node_Id;
+
+            function Satisfies_Lock_Free_Requirements
+              (Sub_Body : Node_Id) return Boolean;
+            --  Return True if protected subprogram body Sub_Body satisfies all
+            --  requirements of a lock-free implementation.
+
+            --------------------------------------
+            -- Satisfies_Lock_Free_Requirements --
+            --------------------------------------
+
+            function Satisfies_Lock_Free_Requirements
+              (Sub_Body : Node_Id) return Boolean
+            is
+               Comp : Entity_Id := Empty;
+               --  Track the current component which the body references
+
+               function Check_Node (N : Node_Id) return Traverse_Result;
+               --  Check that node N meets the lock free restrictions
+
+               ----------------
+               -- Check_Node --
+               ----------------
+
+               function Check_Node (N : Node_Id) return Traverse_Result is
+               begin
+                  --  Function calls and attribute references must be static
+
+                  if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
+                    and then not Is_Static_Expression (N)
+                  then
+                     return Abandon;
+
+                  --  Loop statements and procedure calls are prohibited
+
+                  elsif Nkind_In (N, N_Loop_Statement,
+                                     N_Procedure_Call_Statement)
+                  then
+                     return Abandon;
+
+                  --  References
+
+                  elsif Nkind (N) = N_Identifier
+                    and then Present (Entity (N))
+                  then
+                     declare
+                        Id     : constant Entity_Id := Entity (N);
+                        Sub_Id : constant Entity_Id :=
+                                   Corresponding_Spec (Sub_Body);
+
+                     begin
+                        --  Prohibit references to non-constant entities
+                        --  outside the protected subprogram scope.
+
+                        if Ekind (Id) in Assignable_Kind
+                          and then not Scope_Within_Or_Same (Scope (Id),
+                                         Sub_Id)
+                          and then not Scope_Within_Or_Same (Scope (Id),
+                                         Protected_Body_Subprogram (Sub_Id))
+                        then
+                           return Abandon;
+
+                        --  Prohibit non-scalar out parameters (scalar
+                        --  parameters are passed by copy).
+
+                        elsif Ekind_In (Id, E_Out_Parameter,
+                                            E_In_Out_Parameter)
+                          and then not Is_Scalar_Type (Etype (Id))
+                          and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
+                        then
+                           return Abandon;
+
+                        --  A protected subprogram may reference only one
+                        --  component of the protected type.
+
+                        elsif Ekind (Id) = E_Component then
+                           declare
+                              Comp_Decl : constant Node_Id := Parent (Id);
+                           begin
+                              if Nkind (Comp_Decl) = N_Component_Declaration
+                                and then Is_List_Member (Comp_Decl)
+                                and then List_Containing (Comp_Decl) =
+                                           Priv_Decls
+                              then
+                                 if No (Comp) then
+                                    Comp := Id;
+
+                                 --  Check if another protected component has
+                                 --  already been accessed by the subprogram
+                                 --  body.
+
+                                 elsif Comp /= Id then
+                                    return Abandon;
+                                 end if;
+                              end if;
+                           end;
+
+                        elsif Ekind_In (Id, E_Constant, E_Variable)
+                          and then Present (Prival_Link (Id))
+                        then
+                           declare
+                              Comp_Decl : constant Node_Id :=
+                                            Parent (Prival_Link (Id));
+                           begin
+                              if Nkind (Comp_Decl) = N_Component_Declaration
+                                and then Is_List_Member (Comp_Decl)
+                                and then List_Containing (Comp_Decl) =
+                                           Priv_Decls
+                              then
+                                 if No (Comp) then
+                                    Comp := Prival_Link (Id);
+
+                                 --  Check if another protected component has
+                                 --  already been accessed by the subprogram
+                                 --  body.
+
+                                 elsif Comp /= Prival_Link (Id) then
+                                    return Abandon;
+                                 end if;
+                              end if;
+                           end;
+                        end if;
+                     end;
+                  end if;
+
+                  return OK;
+               end Check_Node;
+
+               function Check_All_Nodes is new Traverse_Func (Check_Node);
+
+            --  Start of processing for Satisfies_Lock_Free_Requirements
+
+            begin
+               if Check_All_Nodes (Sub_Body) = OK then
+
+                  --  Establish a relation between the subprogram body and the
+                  --  unique protected component it references.
+
+                  if Present (Comp) then
+                     Lock_Free_Subprogram_Table.Append
+                       (Lock_Free_Subprogram'(Sub_Body, Comp));
+                  end if;
+
+                  return True;
+               else
+                  return False;
+               end if;
+            end Satisfies_Lock_Free_Requirements;
+
+         begin
+            Decl := First (Decls);
+
+            while Present (Decl) loop
+               if Nkind (Decl) = N_Subprogram_Body
+                 and then not Satisfies_Lock_Free_Requirements (Decl)
+               then
+                  if Complain then
+                     Error_Msg_N ("body prevents lock-free implementation",
+                                  Decl);
+                  end if;
+
+                  return False;
+               end if;
+
+               Next (Decl);
+            end loop;
+         end;
+      end if;
+
+      return True;
+   end Allows_Lock_Free_Implementation;
+
    -----------------------------
    -- Analyze_Abort_Statement --
    -----------------------------
@@ -1057,6 +1381,7 @@ 
 
    procedure Analyze_Protected_Body (N : Node_Id) is
       Body_Id : constant Entity_Id := Defining_Identifier (N);
+      Aspect  : Node_Id;
       Last_E  : Entity_Id;
 
       Spec_Id : Entity_Id;
@@ -1130,6 +1455,42 @@ 
       Check_References (Spec_Id);
       Process_End_Label (N, 't', Ref_Id);
       End_Scope;
+
+      --  Turn on/off the lock-free implementation for the protected object
+
+      --  Look for a Lock_Free aspect with a False expression that disables the
+      --  lock-free implementation.
+
+      Aspect := First (Aspect_Specifications (Parent (Spec_Id)));
+
+      while Present (Aspect) loop
+         if Get_Aspect_Id (Chars (Identifier (Aspect))) = Aspect_Lock_Free
+           and then Present (Expression (Aspect))
+           and then Entity (Expression (Aspect)) = Standard_False
+         then
+            return;
+         end if;
+
+         Next (Aspect);
+      end loop;
+
+      --  When a Lock_Free aspect forces the lock-free implementation, verify
+      --  the protected body meets all the restrictions, otherwise
+      --  Allows_Lock_Free_Implementation issues an error message.
+
+      if Uses_Lock_Free (Spec_Id) then
+         if not Allows_Lock_Free_Implementation (N, Complain => True) then
+            return;
+         end if;
+
+      --  In other cases, check both the protected declaration and body satisfy
+      --  the lock-free restrictions.
+
+      elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
+        and then Allows_Lock_Free_Implementation (N)
+      then
+         Set_Uses_Lock_Free (Spec_Id);
+      end if;
    end Analyze_Protected_Body;
 
    ----------------------------------
@@ -1347,6 +1708,16 @@ 
 
       End_Scope;
 
+      --  When a Lock_Free aspect forces the lock-free implementation, check N
+      --  meets all the lock-free restrictions. Otherwise,
+      --  Allows_Lock_Free_Implementation issue an error message.
+
+      if Uses_Lock_Free (Defining_Identifier (N)) then
+         if not Allows_Lock_Free_Implementation (N, Complain => True) then
+            return;
+         end if;
+      end if;
+
       --  Case of a completion of a private declaration
 
       if T /= Def_Id
@@ -1840,10 +2211,6 @@ 
       --  disastrous result.
 
       Analyze_Protected_Type_Declaration (N);
-
-      if Has_Aspects (N) then
-         Analyze_Aspect_Specifications (N, Id);
-      end if;
    end Analyze_Single_Protected_Declaration;
 
    -------------------------------------
Index: sem_ch9.ads
===================================================================
--- sem_ch9.ads	(revision 187501)
+++ sem_ch9.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -23,6 +23,7 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Table;
 with Types; use Types;
 
 package Sem_Ch9  is
@@ -52,4 +53,35 @@ 
    procedure Analyze_Terminate_Alternative              (N : Node_Id);
    procedure Analyze_Timed_Entry_Call                   (N : Node_Id);
    procedure Analyze_Triggering_Alternative             (N : Node_Id);
+
+   ------------------------------
+   -- Lock Free Data Structure --
+   ------------------------------
+
+   --  A lock-free subprogram is a protected routine which references a unique
+   --  protected scalar component and does not contain statements that cause
+   --  side effects. Due to this restricted behavior, all references to shared
+   --  data from within the subprogram can be synchronized through the use of
+   --  atomic operations rather than relying on locks.
+
+   type Lock_Free_Subprogram is record
+      Sub_Body : Node_Id;
+      --  Reference to the body of a protected subprogram which meets the lock-
+      --  free requirements.
+
+      Comp_Id : Entity_Id;
+      --  Reference to the scalar component referenced from within Sub_Body
+   end record;
+
+   --  This table establishes a relation between a protected subprogram body
+   --  and a unique component it references. The table is used when building
+   --  the lock-free versions of a protected subprogram body.
+
+   package Lock_Free_Subprogram_Table is new Table.Table (
+     Table_Component_Type => Lock_Free_Subprogram,
+     Table_Index_Type     => Nat,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 5,
+     Table_Increment      => 5,
+     Table_Name           => "Lock_Free_Subprogram_Table");
 end Sem_Ch9;
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 187501)
+++ einfo.adb	(working copy)
@@ -452,6 +452,7 @@ 
    --    Is_Ada_2005_Only                Flag185
    --    Is_Interface                    Flag186
    --    Has_Constrained_Partial_View    Flag187
+   --    Uses_Lock_Free                  Flag188
    --    Is_Pure_Unit_Access_Type        Flag189
    --    Has_Specified_Stream_Input      Flag190
 
@@ -525,7 +526,6 @@ 
    --    Has_Anonymous_Master            Flag253
    --    Is_Implementation_Defined       Flag254
 
-   --    (unused)                        Flag188
    --    (unused)                        Flag201
 
    -----------------------
@@ -2794,6 +2794,12 @@ 
       return Flag222 (Id);
    end Used_As_Generic_Actual;
 
+   function Uses_Lock_Free (Id : E) return B is
+   begin
+      pragma Assert (Is_Protected_Type (Id));
+      return Flag188 (Id);
+   end Uses_Lock_Free;
+
    function Uses_Sec_Stack (Id : E) return B is
    begin
       return Flag95 (Id);
@@ -5358,16 +5364,22 @@ 
       Set_Node16 (Id, V);
    end Set_Unset_Reference;
 
+   procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
+   begin
+      Set_Flag222 (Id, V);
+   end Set_Used_As_Generic_Actual;
+
+   procedure Set_Uses_Lock_Free (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Protected_Type);
+      Set_Flag188 (Id, V);
+   end Set_Uses_Lock_Free;
+
    procedure Set_Uses_Sec_Stack (Id : E; V : B := True) is
    begin
       Set_Flag95 (Id, V);
    end Set_Uses_Sec_Stack;
 
-   procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
-   begin
-      Set_Flag222 (Id, V);
-   end Set_Used_As_Generic_Actual;
-
    procedure Set_Warnings_Off (Id : E; V : B := True) is
    begin
       Set_Flag96 (Id, V);
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 187501)
+++ einfo.ads	(working copy)
@@ -3878,6 +3878,12 @@ 
 --       Present in all entities, set if the entity is used as an argument to
 --       a generic instantiation. Used to tune certain warning messages.
 
+--    Uses_Lock_Free (Flag188)
+--       Present in protected type entities. Set to True when the Lock Free
+--       implementation is used for the protected type. This implemenatation is
+--       based on atomic transactions and doesn't require anymore the use of
+--       Protection object (see System.Tasking.Protected_Objects).
+
 --    Uses_Sec_Stack (Flag95)
 --       Present in scope entities (blocks,functions, procedures, tasks,
 --       entries). Set to True when secondary stack is used in this scope and
@@ -5601,6 +5607,7 @@ 
    --    Stored_Constraint                   (Elist23)
    --    Has_Interrupt_Handler               (synth)
    --    Sec_Stack_Needed_For_Return         (Flag167)  ???
+   --    Uses_Lock_Free                      (Flag188)
    --    Uses_Sec_Stack                      (Flag95)   ???
    --    Has_Entries                         (synth)
    --    Number_Entries                      (synth)
@@ -6405,6 +6412,7 @@ 
    function Universal_Aliasing                  (Id : E) return B;
    function Unset_Reference                     (Id : E) return N;
    function Used_As_Generic_Actual              (Id : E) return B;
+   function Uses_Lock_Free                      (Id : E) return B;
    function Uses_Sec_Stack                      (Id : E) return B;
    function Vax_Float                           (Id : E) return B;
    function Warnings_Off                        (Id : E) return B;
@@ -7001,6 +7009,7 @@ 
    procedure Set_Universal_Aliasing              (Id : E; V : B := True);
    procedure Set_Unset_Reference                 (Id : E; V : N);
    procedure Set_Used_As_Generic_Actual          (Id : E; V : B := True);
+   procedure Set_Uses_Lock_Free                  (Id : E; V : B := True);
    procedure Set_Uses_Sec_Stack                  (Id : E; V : B := True);
    procedure Set_Warnings_Off                    (Id : E; V : B := True);
    procedure Set_Warnings_Off_Used               (Id : E; V : B := True);
@@ -7746,6 +7755,7 @@ 
    pragma Inline (Universal_Aliasing);
    pragma Inline (Unset_Reference);
    pragma Inline (Used_As_Generic_Actual);
+   pragma Inline (Uses_Lock_Free);
    pragma Inline (Uses_Sec_Stack);
    pragma Inline (Warnings_Off);
    pragma Inline (Warnings_Off_Used);
@@ -8148,6 +8158,7 @@ 
    pragma Inline (Set_Universal_Aliasing);
    pragma Inline (Set_Unset_Reference);
    pragma Inline (Set_Used_As_Generic_Actual);
+   pragma Inline (Set_Uses_Lock_Free);
    pragma Inline (Set_Uses_Sec_Stack);
    pragma Inline (Set_Warnings_Off);
    pragma Inline (Set_Warnings_Off_Used);
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 187501)
+++ rtsfind.ads	(working copy)
@@ -739,6 +739,8 @@ 
      RE_Atomic_Load_16,                  -- System.Atomic_Primitives
      RE_Atomic_Load_32,                  -- System.Atomic_Primitives
      RE_Atomic_Load_64,                  -- System.Atomic_Primitives
+     RE_Atomic_Synchronize,              -- System.Atomic_Primitives
+     RE_Relaxed,                         -- System.Atomic_Primitives
      RE_Uint8,                           -- System.Atomic_Primitives
      RE_Uint16,                          -- System.Atomic_Primitives
      RE_Uint32,                          -- System.Atomic_Primitives
@@ -1960,6 +1962,8 @@ 
      RE_Atomic_Load_16                   => System_Atomic_Primitives,
      RE_Atomic_Load_32                   => System_Atomic_Primitives,
      RE_Atomic_Load_64                   => System_Atomic_Primitives,
+     RE_Atomic_Synchronize               => System_Atomic_Primitives,
+     RE_Relaxed                          => System_Atomic_Primitives,
      RE_Uint8                            => System_Atomic_Primitives,
      RE_Uint16                           => System_Atomic_Primitives,
      RE_Uint32                           => System_Atomic_Primitives,
Index: aspects.adb
===================================================================
--- aspects.adb	(revision 187501)
+++ aspects.adb	(working copy)
@@ -242,11 +242,13 @@ 
     Aspect_Ada_2012                     => Aspect_Ada_2005,
     Aspect_Address                      => Aspect_Address,
     Aspect_Alignment                    => Aspect_Alignment,
+    Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
     Aspect_Asynchronous                 => Aspect_Asynchronous,
     Aspect_Atomic                       => Aspect_Atomic,
     Aspect_Atomic_Components            => Aspect_Atomic_Components,
     Aspect_Attach_Handler               => Aspect_Attach_Handler,
     Aspect_Bit_Order                    => Aspect_Bit_Order,
+    Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
     Aspect_Component_Size               => Aspect_Component_Size,
     Aspect_Constant_Indexing            => Aspect_Constant_Indexing,
     Aspect_Contract_Case                => Aspect_Contract_Case,
@@ -259,6 +261,7 @@ 
     Aspect_Discard_Names                => Aspect_Discard_Names,
     Aspect_Dispatching_Domain           => Aspect_Dispatching_Domain,
     Aspect_Dynamic_Predicate            => Aspect_Predicate,
+    Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
     Aspect_External_Tag                 => Aspect_External_Tag,
     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
     Aspect_Implicit_Dereference         => Aspect_Implicit_Dereference,
@@ -266,24 +269,12 @@ 
     Aspect_Independent_Components       => Aspect_Independent_Components,
     Aspect_Inline                       => Aspect_Inline,
     Aspect_Inline_Always                => Aspect_Inline,
+    Aspect_Input                        => Aspect_Input,
     Aspect_Interrupt_Handler            => Aspect_Interrupt_Handler,
     Aspect_Interrupt_Priority           => Aspect_Interrupt_Priority,
+    Aspect_Invariant                    => Aspect_Invariant,
     Aspect_Iterator_Element             => Aspect_Iterator_Element,
-    Aspect_All_Calls_Remote             => Aspect_All_Calls_Remote,
-    Aspect_Compiler_Unit                => Aspect_Compiler_Unit,
-    Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
-    Aspect_Preelaborate                 => Aspect_Preelaborate,
-    Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
-    Aspect_Pure                         => Aspect_Pure,
-    Aspect_Pure_05                      => Aspect_Pure_05,
-    Aspect_Pure_12                      => Aspect_Pure_12,
-    Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
-    Aspect_Remote_Types                 => Aspect_Remote_Types,
-    Aspect_Scalar_Storage_Order         => Aspect_Scalar_Storage_Order,
-    Aspect_Shared_Passive               => Aspect_Shared_Passive,
-    Aspect_Universal_Data               => Aspect_Universal_Data,
-    Aspect_Input                        => Aspect_Input,
-    Aspect_Invariant                    => Aspect_Invariant,
+    Aspect_Lock_Free                    => Aspect_Lock_Free,
     Aspect_Machine_Radix                => Aspect_Machine_Radix,
     Aspect_No_Return                    => Aspect_No_Return,
     Aspect_Object_Size                  => Aspect_Object_Size,
@@ -295,12 +286,21 @@ 
     Aspect_Pre                          => Aspect_Pre,
     Aspect_Precondition                 => Aspect_Pre,
     Aspect_Predicate                    => Aspect_Predicate,
+    Aspect_Preelaborate                 => Aspect_Preelaborate,
+    Aspect_Preelaborate_05              => Aspect_Preelaborate_05,
     Aspect_Preelaborable_Initialization => Aspect_Preelaborable_Initialization,
     Aspect_Priority                     => Aspect_Priority,
+    Aspect_Pure                         => Aspect_Pure,
+    Aspect_Pure_05                      => Aspect_Pure_05,
+    Aspect_Pure_12                      => Aspect_Pure_12,
     Aspect_Pure_Function                => Aspect_Pure_Function,
     Aspect_Remote_Access_Type           => Aspect_Remote_Access_Type,
+    Aspect_Remote_Call_Interface        => Aspect_Remote_Call_Interface,
+    Aspect_Remote_Types                 => Aspect_Remote_Types,
     Aspect_Read                         => Aspect_Read,
+    Aspect_Scalar_Storage_Order         => Aspect_Scalar_Storage_Order,
     Aspect_Shared                       => Aspect_Atomic,
+    Aspect_Shared_Passive               => Aspect_Shared_Passive,
     Aspect_Simple_Storage_Pool          => Aspect_Simple_Storage_Pool,
     Aspect_Simple_Storage_Pool_Type     => Aspect_Simple_Storage_Pool_Type,
     Aspect_Size                         => Aspect_Size,
@@ -316,6 +316,7 @@ 
     Aspect_Type_Invariant               => Aspect_Invariant,
     Aspect_Unchecked_Union              => Aspect_Unchecked_Union,
     Aspect_Universal_Aliasing           => Aspect_Universal_Aliasing,
+    Aspect_Universal_Data               => Aspect_Universal_Data,
     Aspect_Unmodified                   => Aspect_Unmodified,
     Aspect_Unreferenced                 => Aspect_Unreferenced,
     Aspect_Unreferenced_Objects         => Aspect_Unreferenced_Objects,
Index: aspects.ads
===================================================================
--- aspects.ads	(revision 187501)
+++ aspects.ads	(working copy)
@@ -142,8 +142,13 @@ 
       Aspect_Unreferenced,                  -- GNAT
       Aspect_Unreferenced_Objects,          -- GNAT
       Aspect_Volatile,
-      Aspect_Volatile_Components);
+      Aspect_Volatile_Components,
 
+      --  Aspects that have a static boolean value but don't correspond to
+      --  pragmas
+
+      Aspect_Lock_Free);
+
    --  The following array indicates aspects that accept 'Class
 
    Class_Aspect_OK : constant array (Aspect_Id) of Boolean :=
@@ -182,6 +187,7 @@ 
                              Aspect_Dimension_System         => True,
                              Aspect_Favor_Top_Level          => True,
                              Aspect_Inline_Always            => True,
+                             Aspect_Lock_Free                => True,
                              Aspect_Object_Size              => True,
                              Aspect_Persistent_BSS           => True,
                              Aspect_Predicate                => True,
@@ -352,6 +358,7 @@ 
      Aspect_Interrupt_Priority           => Name_Interrupt_Priority,
      Aspect_Invariant                    => Name_Invariant,
      Aspect_Iterator_Element             => Name_Iterator_Element,
+     Aspect_Lock_Free                    => Name_Lock_Free,
      Aspect_Machine_Radix                => Name_Machine_Radix,
      Aspect_No_Return                    => Name_No_Return,
      Aspect_Object_Size                  => Name_Object_Size,
Index: s-atopri.ads
===================================================================
--- s-atopri.ads	(revision 187501)
+++ s-atopri.ads	(working copy)
@@ -29,8 +29,11 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  ??? Need header saying what this unit is!!!
+--  This package contains atomic primitives defined from gcc built-in functions
 
+--  For now, these operations are only used by the compiler to generate the
+--  lock-free implementation of protected objects.
+
 package System.Atomic_Primitives is
    pragma Preelaborate;
 
@@ -119,4 +122,6 @@ 
       Model : Mem_Model := Seq_Cst) return uint64;
    pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8");
 
+   procedure Atomic_Synchronize;
+   pragma Import (Intrinsic, Atomic_Synchronize, "__sync_synchronize");
 end System.Atomic_Primitives;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 187501)
+++ sem_ch13.adb	(working copy)
@@ -926,16 +926,40 @@ 
                when No_Aspect =>
                   raise Program_Error;
 
-               --  Aspects taking an optional boolean argument. For all of
-               --  these we just create a matching pragma and insert it, if
-               --  the expression is missing or set to True. If the expression
-               --  is False, we can ignore the aspect with the exception that
-               --  in the case of a derived type, we must check for an illegal
-               --  attempt to cancel an inherited aspect.
+               --  Aspects taking an optional boolean argument
 
                when Boolean_Aspects =>
                   Set_Is_Boolean_Aspect (Aspect);
 
+                  --  Special treatment for Aspect_Lock_Free since it is the
+                  --  only Boolean_Aspect that doesn't correspond to a pragma.
+
+                  if A_Id = Aspect_Lock_Free then
+                     if Ekind (E) /= E_Protected_Type then
+                        Error_Msg_N
+                          ("aspect % only applies to protected objects",
+                           Aspect);
+                     end if;
+
+                     --  Set the Uses_Lock_Free flag to True if there is no
+                     --  expression or if the expression is True.
+
+                     if No (Expr)
+                       or else Is_True (Static_Boolean (Expr))
+                     then
+                        Set_Uses_Lock_Free (E);
+                     end if;
+
+                     goto Continue;
+                  end if;
+
+                  --  For all of these aspects we just create a matching pragma
+                  --  and insert it, if the expression is missing or set to
+                  --  True. If the expression is False, we can ignore the
+                  --  aspect with the exception that in the case of a derived
+                  --  type, we must check for an illegal attempt to cancel an
+                  --  inherited aspect.
+
                   if Present (Expr)
                     and then Is_False (Static_Boolean (Expr))
                   then
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 187501)
+++ snames.ads-tmpl	(working copy)
@@ -142,6 +142,7 @@ 
    Name_Dimension                      : constant Name_Id := N + $;
    Name_Dimension_System               : constant Name_Id := N + $;
    Name_Dynamic_Predicate              : constant Name_Id := N + $;
+   Name_Lock_Free                      : constant Name_Id := N + $;
    Name_Post                           : constant Name_Id := N + $;
    Name_Pre                            : constant Name_Id := N + $;
    Name_Static_Predicate               : constant Name_Id := N + $;