diff --git a/src/proto_alpha/lib_protocol/src/alpha_context.mli b/src/proto_alpha/lib_protocol/src/alpha_context.mli
index 190af58c3..abf127dbb 100644
--- a/src/proto_alpha/lib_protocol/src/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/src/alpha_context.mli
@@ -731,6 +731,7 @@ module Roll : sig
 
   val value: context -> Tez.t
 
+  val snapshot_rolls: context -> context tzresult Lwt.t
   val cycle_end: context -> Cycle.t -> context tzresult Lwt.t
 
   val baking_rights_owner:
diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml
index 19cfc8877..afedbd78d 100644
--- a/src/proto_alpha/lib_protocol/src/apply.ml
+++ b/src/proto_alpha/lib_protocol/src/apply.ml
@@ -329,6 +329,18 @@ let apply_operation
       return (ctxt, Contract.originated_contracts origination_nonce, err,
               Ok fees, Ok rewards)
 
+let may_snapshot_roll ctxt =
+  let level = Alpha_context.Level.current ctxt in
+  let block_per_roll_snapshot = Constants.block_per_roll_snapshot ctxt in
+  if Compare.Int32.equal
+      (Int32.rem level.cycle_position block_per_roll_snapshot)
+      (Int32.pred block_per_roll_snapshot)
+  then
+    Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt ->
+    return ctxt
+  else
+    return ctxt
+
 let may_start_new_cycle ctxt =
   Baking.dawn_of_a_new_cycle ctxt >>=? function
   | None -> return ctxt
@@ -387,6 +399,7 @@ let finalize_application ctxt protocol_data delegate bond fees rewards =
           { nonce_hash ; delegate ; bond ; rewards ; fees }
   end >>=? fun ctxt ->
   (* end of cycle *)
+  may_snapshot_roll ctxt >>=? fun ctxt ->
   may_start_new_cycle ctxt >>=? fun ctxt ->
   Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt ->
   return ctxt
diff --git a/src/proto_alpha/lib_protocol/src/roll_storage.ml b/src/proto_alpha/lib_protocol/src/roll_storage.ml
index ab0694179..56311ca82 100644
--- a/src/proto_alpha/lib_protocol/src/roll_storage.ml
+++ b/src/proto_alpha/lib_protocol/src/roll_storage.ml
@@ -61,12 +61,34 @@ let fold ctxt ~f init =
           loop ctxt (Roll_repr.succ roll) (f roll delegate acc) in
   loop ctxt Roll_repr.first (return init)
 
-let freeze_rolls_for_cycle ctxt cycle =
-  let index = 0 in
+let snapshot_rolls_for_cycle ctxt cycle =
+  Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun index ->
+  Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1) >>=? fun ctxt ->
   Storage.Roll.Owner.snapshot ctxt (cycle, index) >>=? fun ctxt ->
   Storage.Roll.Next.get ctxt >>=? fun last ->
-  Storage.Roll.Snapshot_for_cycle.init ctxt cycle index >>=? fun ctxt ->
-  Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
+  Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last >>=? fun ctxt ->
+  return ctxt
+
+let freeze_rolls_for_cycle ctxt cycle =
+  Storage.Roll.Snapshot_for_cycle.get ctxt cycle >>=? fun max_index ->
+  Storage.Seed.For_cycle.get ctxt cycle >>=? fun seed ->
+  let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
+  let seq = Seed_repr.sequence rd 0l in
+  let selected_index =
+    Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int in
+  Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index >>=? fun ctxt ->
+  fold_left_s
+    (fun ctxt index ->
+       if Compare.Int.(index = selected_index) then
+         return ctxt
+       else
+         Storage.Roll.Owner.delete_snapshot ctxt (cycle, index) >>= fun ctxt ->
+         Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index >>=? fun ctxt ->
+         return ctxt
+    )
+    ctxt
+    Misc.(0 --> (max_index - 1)) >>=? fun ctxt ->
+  return ctxt
 
 (* Roll selection *)
 
@@ -252,14 +274,30 @@ let init ctxt =
 
 let init_first_cycles ctxt =
   let preserved = Constants_storage.preserved_cycles ctxt in
+  (* Precompute rolls for cycle (0 --> preserved_cycles) *)
   List.fold_left
     (fun ctxt c ->
        ctxt >>=? fun ctxt ->
        let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
+       Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
+       snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt ->
        freeze_rolls_for_cycle ctxt cycle)
-    (return ctxt) (0 --> (preserved + 1)) >>=? fun ctxt ->
+    (return ctxt) (0 --> preserved) >>=? fun ctxt ->
+  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
+  (* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
+  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
+  snapshot_rolls_for_cycle ctxt cycle >>=? fun ctxt ->
+  (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
+  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
+  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0 >>=? fun ctxt ->
   return ctxt
 
+let snapshot_rolls ctxt =
+  let current_level = Raw_context.current_level ctxt in
+  let preserved = Constants_storage.preserved_cycles ctxt in
+  let cycle = Cycle_repr.add current_level.cycle (preserved+2) in
+  snapshot_rolls_for_cycle ctxt cycle
+
 let cycle_end ctxt last_cycle =
   let preserved = Constants_storage.preserved_cycles ctxt in
   begin
@@ -268,5 +306,8 @@ let cycle_end ctxt last_cycle =
     | Some cleared_cycle ->
         clear_cycle ctxt cleared_cycle
   end >>=? fun ctxt ->
-  let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved+2) in
-  freeze_rolls_for_cycle ctxt frozen_roll_cycle
+  let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved+1) in
+  freeze_rolls_for_cycle ctxt frozen_roll_cycle >>=? fun ctxt ->
+  Storage.Roll.Snapshot_for_cycle.init
+    ctxt (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0 >>=? fun ctxt ->
+  return ctxt
diff --git a/src/proto_alpha/lib_protocol/src/roll_storage.mli b/src/proto_alpha/lib_protocol/src/roll_storage.mli
index b2ba0aa8e..97cbc4e6d 100644
--- a/src/proto_alpha/lib_protocol/src/roll_storage.mli
+++ b/src/proto_alpha/lib_protocol/src/roll_storage.mli
@@ -26,6 +26,8 @@ val init : Raw_context.t -> Raw_context.t tzresult Lwt.t
 val init_first_cycles : Raw_context.t -> Raw_context.t tzresult Lwt.t
 
 val cycle_end : Raw_context.t -> Cycle_repr.t -> Raw_context.t tzresult Lwt.t
+val snapshot_rolls : Raw_context.t -> Raw_context.t tzresult Lwt.t
+
 
 val fold :
   Raw_context.t ->
diff --git a/src/proto_alpha/lib_protocol/src/seed_storage.ml b/src/proto_alpha/lib_protocol/src/seed_storage.ml
index 4bba561ba..d6a8b501f 100644
--- a/src/proto_alpha/lib_protocol/src/seed_storage.ml
+++ b/src/proto_alpha/lib_protocol/src/seed_storage.ml
@@ -65,7 +65,11 @@ let for_cycle ctxt cycle =
   let preserved = Constants_storage.preserved_cycles ctxt in
   let current_level = Level_storage.current ctxt in
   let current_cycle = current_level.cycle in
-  let latest = Cycle_repr.add current_cycle preserved in
+  let latest =
+    if Cycle_repr.(current_cycle = root) then
+      Cycle_repr.add current_cycle (preserved + 1)
+    else
+      Cycle_repr.add current_cycle preserved in
   let oldest =
     match Cycle_repr.sub current_cycle preserved with
     | None -> Cycle_repr.root