L’objectif est de comparer des stratégies clairvoyantes, i.e., ayant la connaissance de la durée des tâches à ordonnancer avec des stratégies non-clairvoyantes comme FIFO ou LIFO. Le processus d’arrivée est un processus de Poisson de taux (débit), les clients ont un temps de service de moyenne 1 pris comme unité de temps de référence.

Simulation de la file LIFO et des différentes politiques clairvoyantes

Afin de pouvoir faire des comparaisons “fines” entre les différentes politiques, je ne vais retravailler un peu l’interface de la fonction de simulation afin que les temps de service et d’arrivée ne soient pas générés dans la fonction de simulation mais à l’extérieur. Ainsi, on pourra exécuter des simulations avec exactement le même workload en entrée (même dates d’arrivées et même temps de traitement). J’ai pu me permettre de faire cette modification car il n’y a pas de reset ou de restart des temps de service.

Une fois ceci fait, j’ai légèrement modifié run_task et push_task de façon à ce que le remaining soit NA quand la tache n’est pas encore arrivée ou bien qu’elle est terminée et que remaining soit fixé à service au moment de l’arrivée dans le système, c’est-à-dire au moment du push.

Ensuite, j’ai modifié run_task afin de trouver la tache la plus prioritaire. Dans le cas de fifo, c’est la première tache de waiting. Dans le cas de lifo, c’est la dernière. Dans le cas de srpt, c’est celle qui atteint le min du remaining (ce qui s’écrit bien avec un which.min), etc. Une fois l’index de la tache dans le tableau waiting repéré, il est facile de mettre à jour les différentes variables.

set.seed(10)
library(plyr)
library(ggplot2)

Service <- function(n=1,typeservice,x,y) {
# genere un temps de service
  switch(typeservice,
         det = rep(1,n),
         uni = runif(n,x,y),
         gamma = rgamma(n,shape=x,scale=y),
         exp = rexp(n,x)
         )
}

ArrivalDates <- function(n=1,lambda) {
    cumsum(rexp(n,lambda))
}

defined_policies = c("lifo","lifo_pmtn","fifo","spt","srpt_pmtn","spt_pmtn")

Simulate <- function(arrival, service, policy) {
    # simulates a M/GI/1 LIFO or FIFO queue with different preemption policy
    # returns a vector with the response time of each task assuming the queue is initially empty
    
    n = length(arrival);
    if(length(service)!=n) {
      stop("Incompatible sizes for Arrival and Service (",length(arrival),length(service),")");
    } 
    if(!(policy %in% defined_policies)) {
      stop(paste("Unknown policy: ",policy));
    }
    t1 = arrival;
    S = service;
    t2 <- rep(NA,n)
    
    #### Variables that define the state of the queue
    t = 0               # current time
    remaining = rep(NA,n)  # how much work remains to do for each task
    running = NA        # index of the currently running task
    waiting = c()       # stack with tasks which have arrived and have not been completed yet
    next_arrival = 1    # index of the next task to arrive
    
    #### A few useful local functions 
    run_task = function() { # runs the task with the highest priority
      if(length(waiting)>0) {
        idx = switch(policy,
                     "lifo" = length(waiting),
                     "lifo_pmtn" = length(waiting),
                     "fifo" = 1,
                     "srpt_pmtn" = which.min(remaining[waiting]),
                     "spt_pmtn" = which.min(S[waiting]),
                     "spt" = which.min(S[waiting])
                     )
        running <<- waiting[idx]
        waiting <<- waiting[-idx]
      }
    }

    push_task = function() { # insert the next_arrival-th task to the waiting list
                             # and run it if there is preemption
      if(length(grep("_pmtn",policy))) {
        if(!is.na(running)) {waiting <<- c(waiting,running)}
        running <<- NA
      }
      waiting <<- c(waiting,next_arrival)
      remaining[next_arrival] <<- S[next_arrival]
      next_arrival <<- next_arrival+1 
      if(is.na(running)) { run_task() }
    }

    #### Main simulation loop
    while(TRUE) { 
      # Look for next event
      dt = NA
      if(next_arrival <=n) { dt = min(dt,(t1[next_arrival]-t), na.rm=T) }
      if(!is.na(running))  { dt = min(dt,remaining[running], na.rm=T)   }
      if(is.na(dt)) { break }
      
      # Update state
      t=t+dt
      if(!is.na(running)) {
        remaining[running] = remaining[running] - dt
        if(remaining[running]<=0) {
          t2[running] = t
          remaining[running] = NA
          running = NA
          run_task()
        }
      }
      if((next_arrival<=n) & (t==t1[next_arrival])) {
        push_task()
      }
    }
    
    t2-t1
}

Bon, “vérifions” que ça marche.

n=4000;
a = ArrivalDates(n,.3);
s = Service(n,typeservice = "exp", x = 1.0);
for(p in defined_policies) {
  print(paste(p,": ",mean(Simulate(arrival = a, service = s, policy = p))));
}
## [1] "lifo :  1.48924209841799"
## [1] "lifo_pmtn :  1.49128947779878"
## [1] "fifo :  1.49281250650286"
## [1] "spt :  1.4155284532966"
## [1] "srpt_pmtn :  1.2381081608305"
## [1] "spt_pmtn :  1.29002064287785"

Ça a l’air cohérent. Je ne vois pas de grosse différence entre lifo, lifo_pmtn et fifo. À coté de ça, spt a l’air un peu mieux, spt_pmtn encore mieux, et srpt_pmtn encore mieux. Personellement, ça correspond à l’intuition que j’avais mais on va vérifier tout ça.

Comparaison des différentes politiques en terme de temps de réponse moyen

create <- function(n=10000,lambdas = c(0.2,0.4,0.6,0.8),typeservice="exp",x=1,y=NA,
                   policies = defined_policies) {
  d <- data.frame();
  for (lambda in lambdas) {
    s = Service(n,typeservice = typeservice, x = x, y = y);
    a = ArrivalDates(n,lambda);
    for (policy in policies) {
#      print(paste(policy,lambda,sep=" ")) # ça, c'est juste pour suivre l'avancement
      r = Simulate(arrival = a, service = s, policy = policy)
#      d = rbind(d,data.frame(lambda=lambda, policy=policy, resp_m = mean(r), 
#                             resp_ci = 2*sd(r)/sqrt(length(r))))
      d = rbind(d,data.frame(lambda=lambda, policy=policy, arrival = a, 
                             service = s, response = r, index = 1:n))
 }
  }
  
  d$input_type = typeservice
  d$input_p1 = x
  d$input_p2 = y
  d$label = as.factor(paste(typeservice,"(",x,",",y,")",sep=""))
  d
}

Essayons avec un échantillonnage relativement grossier (et encore, 10000, c’est déjà pas mal) et regardons si le temps que ça prend est raisonnable.

system.time(df <- create())
##    user  system elapsed 
##  12.560   0.008  12.579

Moins de 10 secondes sur ma machine. Ça me va. Alors, comment se comparent ces différentes politiques de service ?

df_summary = ddply(df, c("lambda","label","policy"), summarize,
                   response_mean=mean(response), response_sd=sd(response),
                   response_num=length(response), 
                   response_ci=2*response_sd/sqrt(response_num))
p = ggplot(df_summary,aes(x=lambda, y=response_mean, color=policy, shape=policy)) + 
  geom_line() + 
  geom_point() + 
  geom_errorbar(aes(ymin=response_mean-response_ci, ymax=response_mean+response_ci),
                width = .02) +
  scale_color_brewer(palette="Dark2")+
  labs(title= "Temps de réponse moyen en fonction de la charge en entrée") + 
  xlab("Débit normalisé d'entrée (clients/unité de temps)\n(Temps de service = 1 unité de temps)") +
  ylab("Unités de temps") +  xlim(0,1) + ylim(0,NA) +
  geom_vline(xintercept = 1) + geom_hline(yintercept = 1) + theme_bw()
p

plot of chunk unnamed-chunk-6

Les intervalles de confiances sont similaires à ce qu’on avait pu voir avant dans le cas d’études de M/M/1, c’est à dire relativement étroits et de taille croissante avec le taux d’arrivée. Comme dans les études précédentes, on ne voit pas de différences entre lifo, fifo et lifo_pmtn. On a par contre clairement: srpt_pmtn < spt_pmtn < spt < fifo=lifo=lifo_pmtn. Donc la préemption aide (spt_pmtn < spt) à être réactif et il vaut mieux faire passer les petites tâches en premier. C’est assez logique puisque minimiser le temps de réponse moyen c’est la même chose (Little) que minimiser la taille de la file. Et pour ça, quoi de mieux que de toujours travailler sur la tâche pour laquelle il reste le moins de travail à faire. srpt_pmtn est en fait optimale et ça se montre avec un simple argument d’échange assez classique en ordonnancement. Si à un instant donné, il y a 2 tâches \(A\) et \(B\) telles qu’il reste moins de travail à faire pour \(A\) que pour \(B\) (i.e., \(r(A)<r(B)\)) et que \(B\) termine quand même avant \(A\) (i.e., \(t_{end}(B)<t_{end}(A)\) en), alors en travaillant en priorité sur \(A\) plutôt que sur \(B\), on fera en sorte que \(t'_{end}(B)=t_{end}(A)\) et \(t'_{end}(A)<t_{end}(B)\). On aura donc \(t'_{end}(A)+t'_{end}(B) < t_{end}(A) + t_{end}(B)\) et on aura donc strictement amélioré le temps de réponse total… Et quand on améliore le temps de réponse total, on améliore le temps de réponse moyen. Faites un petit dessin, vous allez voir, ça vous éclairera.

Étude de l’équité des différentes stratégies

L’inconvénient de la stratégie srpt_pmtn, c’est que les “grosses tâches passent après toutes les autres et potentiellement même”indéfiniment“… Regardons donc un peu plus en détail la distribution des temps de réponse selon les différentes politiques

df <- create(n = 400, lambdas = c(.6))

df_summary <- ddply(df,c("lambda","policy","label"),summarize,
                    mean=mean(response), max=max(response), 
                    median=median(response), ci=2*sd(response)/sqrt(length(response)))

ggplot(df, aes(x=response)) + geom_histogram(fill="gray",color="black") +
   geom_vline(data=df_summary, aes(xintercept=mean)) +
   geom_text(data=df_summary, aes(x=mean,y=200),color="black",label="mean") +
   geom_vline(data=df_summary, aes(xintercept=max),color="red") +
   geom_text(data=df_summary, aes(x=max,y=200),color="red",label="max") +
   geom_vline(data=df_summary, aes(xintercept=median),color="darkgreen") +
   geom_text(data=df_summary, aes(x=median,y=180),color="darkgreen",label="median") +
   facet_wrap(~policy) + theme_bw() 
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.
## stat_bin: binwidth defaulted to range/30. Use 'binwidth = x' to adjust this.

plot of chunk unnamed-chunk-7

La politique fifo est celle où les temps de réponse sont les plus “ramassés”. Le plus grand temps de réponse est bien plus faible que dans les autres situations. Comme on pouvait s’y attendre, la politique lifo_pmtn qui passe son temps à interrompre les tâches pour servir celle vient d’arriver, a le plus grand temps de réponse. Enfin srpt_pmtn, qui minimise le temps de réponse moyen a un temps de réponse max bien supérieur à celui de fifo.

Les histogrammes n’étant pas forcément faciles à comparer les uns aux autres, j’essaie une autre représentation, avec des boxplots.

ggplot(df, aes(y=response,x=policy)) + geom_boxplot() + geom_jitter(alpha=.1) + theme_bw() + 
  geom_point(data=df_summary,aes(x=policy, y=mean),color="red",size=3) + 
  geom_errorbar(data=df_summary,aes(x=policy, y=mean, ymin=mean-ci, ymax=mean+ci),color="red",width=.3)

plot of chunk unnamed-chunk-8 On arrive bien à la même conclusion.

Illustrons donc autre chose: le temps d’attente en fonction du temps de service.

ggplot(df, aes(x=service,y=response-service)) + geom_point(alpha=.1) + geom_smooth(method="lm") +
    facet_wrap(~policy) + theme_bw()

plot of chunk unnamed-chunk-9 Dans le cas de fifo, le temps d’attente est assez élevé mais ça ne semble pas vraiment influencé par le temps de service. La distribution du temps d’attente pour les petites tâches ressemble à celui pour les moyennes. Et si on a l’impression que le temps d’attente est plus faible pour les grosses tâches, ça peut être dû au fait qu’il y a peu de grosses tâches et que l’échantillonnage n’est pas vraiment représentatif. J’ai rajouté une régression linéaire (plus pour voir une tendance qu’autre chose) et le temps d’attente semble effectivement indépendant du temps de service. Pour lifo_pmtn, on peut voir une variabilité très importante et un temps de réponse qui augmente avec le temps de service. C’est assez logique. Plus une tâche est longue plus elle a de chance d’être préemptée et déschédulée par les tâches plus courtes qui arrivent. Elle restera quand même prioritaire par rapport à des tâches plus courtes qui seraient arrivées après elle et qui n’auraient pas pu être terminées. Regardons enfin srpt_pmtn. Les petites tâches on systématiquement un temps d’attente proche de zéro tandis que les grosses tâches peuvent être beaucoup retardées. On observe finalement à peu près la même chose pour spt_pmtn et ses performances sont proches. Seulement, difficile de donner l’intuition derrière spt_pmtn ou de démontrer quoi que ce soit sur ses performances…

Notez que le fait d’avoir choisi exactement le même scénario pour chacune des politiques aide beaucoup dans la comparaison. En fait, je pourrais même comparer le temps de réponse selon la politique, tâche par tâche… La manipulation est un peu plus compliquée (mais ce qui est important, c’est de regarder à quoi ressemble la data frame initiale et à quoi ressemble à la data frame finale…) cependant mais allons-y.

library(reshape)
## 
## Attaching package: 'reshape'
## 
## The following objects are masked from 'package:plyr':
## 
##     rename, round_any
dd = df[names(df) %in% c("policy","response","index")]
dd = dd[dd$policy %in% c("fifo","srpt_pmtn"),]
# Erm, je ne sais pas faire ça avec une one-liner type melt ou reshape... :( Tant pis, à l'ancienne!
dd1 = dd[dd$policy == "fifo",]
dd2 = dd[dd$policy == "srpt_pmtn",]
dd1$resp_fifo=dd1$resp
dd2$resp_srpt=dd2$resp
dd1 = dd1[!(names(dd1) %in% c("policy","response"))]
dd2 = dd2[!(names(dd2) %in% c("policy","response"))]
dd = merge(dd1,dd2)

ggplot(dd, aes(x=index, y=resp_fifo-resp_srpt)) + 
    geom_point(aes(color=factor(sign(resp_fifo-resp_srpt)))) +
    geom_line(alpha=.4) + theme_bw() + coord_cartesian(ylim = c(-10,10))

plot of chunk unnamed-chunk-10

Bon, j’ai du zoomer pour qu’on voit un peu mieux et j’ai du coup connecté mes points par des lignes afin pour qu’on puisse reprérer les points qui sortent du cadre. J’ai aussi pris soin de colorier les points en fonction de si la différence était nulle, positive ou négative. Ça illustre une fois encore que les temps de réponse pour fifo sont globalement supérieurs à ceux pour srpt_pmt mais je ne suis pas sûr que ça permette de mieux comprendre les choses. Ce qu’il est important de comprendre du point de vue de l’analyse, c’est que je peux me permettre de regarder ce genre de différence car les scénarios sont exactement les mêmes pour les deux simulations.