unfinished/benchmark/richards/richards.factor

   1 ! Based on http://research.sun.com/people/mario/java_benchmarking/
   2 ! Ported by Factor by Slava Pestov
   3 !
   4 ! Based on original version written in BCPL by Dr Martin Richards
   5 ! in 1981 at Cambridge University Computer Laboratory, England
   6 ! Java version:  Copyright (C) 1995 Sun Microsystems, Inc.
   7 ! by Jonathan Gibbons.
   8 ! Outer loop added 8/7/96 by Alex Jacoby
   9 USING: values kernel accessors math math.bitwise sequences
  10 arrays combinators fry locals ;
  11 IN: benchmark.richards
  12
  13 ! Packets
  14 TUPLE: packet link id kind a1 a2 ;
  15
  16 : BUFSIZE 4 ; inline
  17
  18 : <packet> ( link id kind -- packet )
  19     packet new
  20         swap >>kind
  21         swap >>id
  22         swap >>link
  23         0 >>a1
  24         BUFSIZE 0 <array> >>a2 ;
  25
  26 : last-packet ( packet -- last )
  27     dup link>> [ last-packet ] [ ] ?if ;
  28
  29 : append-to ( packet list -- packet )
  30     [ f >>link ] dip
  31     [ tuck last-packet >>link drop ] when* ;
  32
  33 ! Tasks
  34 : I_IDLE 1 ; inline
  35 : I_WORK 2 ; inline
  36 : I_HANDLERA 3 ; inline
  37 : I_HANDLERB 4 ; inline
  38 : I_DEVA 5 ; inline
  39 : I_DEVB 6 ; inline
  40
  41 ! Packet types
  42 : K_DEV 1000 ; inline
  43 : K_WORK 1001 ; inline
  44
  45 : PKTBIT 1 ; inline
  46 : WAITBIT 2 ; inline
  47 : HOLDBIT 4 ; inline
  48
  49 : S_RUN 0 ;  inline
  50 : S_RUNPKT ( -- n ) { PKTBIT } flags ; inline
  51 : S_WAIT ( -- n ) { WAITBIT } flags ; inline
  52 : S_WAITPKT ( -- n ) { WAITBIT PKTBIT } flags ; inline
  53 : S_HOLD ( -- n ) { HOLDBIT } flags ; inline
  54 : S_HOLDPKT ( -- n ) { HOLDBIT PKTBIT } flags ; inline
  55 : S_HOLDWAIT ( -- n ) { HOLDBIT WAITBIT } flags ; inline
  56 : S_HOLDWAITPKT ( -- n ) { HOLDBIT WAITBIT PKTBIT } flags ; inline
  57
  58 : task-tab-size 10 ; inline
  59
  60 VALUE: task-tab
  61 VALUE: task-list
  62 VALUE: tracing
  63 VALUE: hold-count
  64 VALUE: qpkt-count
  65
  66 TUPLE: task link id pri wkq state ;
  67
  68 : new-task ( id pri wkq state class -- task )
  69     new
  70         swap >>state
  71         swap >>wkq
  72         swap >>pri
  73         swap >>id
  74         task-list >>link
  75         dup to: task-list
  76         dup dup id>> task-tab set-nth ; inline
  77
  78 GENERIC: fn ( packet task -- task )
  79
  80 : state-on ( task flag -- task )
  81     '[ _ bitor ] change-state ; inline
  82
  83 : state-off ( task flag -- task )
  84     '[ _ bitnot bitand ] change-state ; inline
  85
  86 : wait-task ( task -- task )
  87     WAITBIT state-on ;
  88
  89 : hold ( task -- task )
  90     hold-count 1+ to: hold-count
  91     HOLDBIT state-on
  92     link>> ;
  93
  94 : highest-priority ( t1 t2 -- t1/t2 )
  95     [ [ pri>> ] bi@ > ] most ;
  96
  97 : find-tcb ( i -- task )
  98     task-tab nth [ "Bad task" throw ] unless* ;
  99
 100 : release ( task i -- task )
 101     find-tcb HOLDBIT state-off highest-priority ;
 102
 103 :: qpkt ( task pkt -- task )
 104     [let | t [ pkt id>> find-tcb ] |
 105         t [
 106             qpkt-count 1+ to: qpkt-count
 107             f pkt (>>link)
 108             task id>> pkt (>>id)
 109             t wkq>> [
 110                 pkt t wkq>> append-to t (>>wkq)
 111                 task
 112             ] [
 113                 pkt t (>>wkq)
 114                 t PKTBIT state-on drop
 115                 t task highest-priority
 116             ] if
 117         ] [ task ] if
 118     ] ;
 119
 120 : schedule-waitpkt ( task -- task pkt )
 121     dup wkq>>
 122     2dup link>> >>wkq drop
 123     2dup S_RUNPKT S_RUN ? >>state drop ; inline
 124
 125 : schedule-run ( task pkt -- task )
 126     swap fn ; inline
 127
 128 : schedule-wait ( task -- task )
 129     link>> ; inline
 130
 131 : (schedule) ( task -- )
 132     [
 133         dup state>> {
 134             { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] }
 135             { S_RUN [ f schedule-run (schedule) ] }
 136             { S_RUNPKT [ f schedule-run (schedule) ] }
 137             { S_WAIT [ schedule-wait (schedule) ] }
 138             { S_HOLD [ schedule-wait (schedule) ] }
 139             { S_HOLDPKT [ schedule-wait (schedule) ] }
 140             { S_HOLDWAIT [ schedule-wait (schedule) ] }
 141             { S_HOLDWAITPKT [ schedule-wait (schedule) ] }
 142             [ 2drop ]
 143         } case
 144     ] when* ;
 145
 146 : schedule ( -- )
 147     task-list (schedule) ;
 148
 149 ! Device task
 150 TUPLE: device-task < task v1 ;
 151
 152 : <device-task> ( id pri wkq -- task )
 153     dup S_WAITPKT S_WAIT ? device-task new-task ;
 154
 155 M:: device-task fn ( pkt task -- task )
 156     pkt [
 157         task dup v1>>
 158         [ wait-task ]
 159         [ [ f ] change-v1 swap qpkt ] if
 160     ] [ pkt task (>>v1) task hold ] if ;
 161
 162 TUPLE: handler-task < task workpkts devpkts ;
 163
 164 : <handler-task> ( id pri wkq -- task )
 165     dup S_WAITPKT S_WAIT ? handler-task new-task ;
 166
 167 M:: handler-task fn ( pkt task -- task )
 168     pkt [
 169         task over kind>> K_WORK =
 170         [ [ append-to ] change-workpkts ]
 171         [ [ append-to ] change-devpkts ]
 172         if drop
 173     ] when*
 174
 175     task workpkts>> [
 176         [let* | devpkt [ task devpkts>> ]
 177                 workpkt [ task workpkts>> ]
 178                 count [ workpkt a1>> ] |
 179             count BUFSIZE > [
 180                 workpkt link>> task (>>workpkts)
 181                 task workpkt qpkt
 182             ] [
 183                 devpkt [
 184                     devpkt link>> task (>>devpkts)
 185                     count workpkt a2>> nth devpkt (>>a1)
 186                     count 1+ workpkt (>>a1)
 187                     task devpkt qpkt
 188                 ] [
 189                     task wait-task
 190                 ] if
 191             ] if
 192         ]
 193     ] [ task wait-task ] if ;
 194
 195 ! Idle task
 196 TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ;
 197
 198 : <idle-task> ( i a1 a2 -- task )
 199     [ 0 f S_RUN idle-task new-task ] 2dip
 200     [ >>v1 ] [ >>v2 ] bi* ;
 201
 202 M: idle-task fn ( pkt task -- task )
 203     nip
 204     [ 1- ] change-v2
 205     dup v2>> 0 = [ hold ] [
 206         dup v1>> 1 bitand 0 = [
 207             [ -1 shift ] change-v1
 208             I_DEVA release
 209         ] [
 210             [ -1 shift HEX: d008 bitor ] change-v1
 211             I_DEVB release
 212         ] if
 213     ] if ;
 214
 215 ! Work task
 216 TUPLE: work-task < task { handler fixnum } { n fixnum } ;
 217
 218 : <work-task> ( id pri w -- work-task )
 219     dup S_WAITPKT S_WAIT ? work-task new-task
 220     I_HANDLERA >>handler
 221     0 >>n ;
 222
 223 M:: work-task fn ( pkt task -- task )
 224     pkt [
 225         task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop
 226         task handler>> pkt (>>id)
 227         0 pkt (>>a1)
 228         BUFSIZE [| i |
 229             task [ 1+ ] change-n drop
 230             task n>> 26 > [ 1 task (>>n) ] when
 231             task n>> 1 - CHAR: A + i pkt a2>> set-nth
 232         ] each
 233         task pkt qpkt
 234     ] [ task wait-task ] if ;
 235
 236 ! Main
 237 : init ( -- )
 238     task-tab-size f <array> to: task-tab
 239     f to: tracing
 240     0 to: hold-count
 241     0 to: qpkt-count ;
 242
 243 : start ( -- )
 244     I_IDLE 1 10000 <idle-task> drop
 245
 246     I_WORK 1000
 247     f 0 K_WORK <packet> 0 K_WORK <packet>
 248     <work-task> drop
 249
 250     I_HANDLERA 2000
 251     f I_DEVA K_DEV <packet>
 252     I_DEVA K_DEV <packet>
 253     I_DEVA K_DEV <packet>
 254     <handler-task> drop
 255
 256     I_HANDLERB 3000
 257     f I_DEVB K_DEV <packet>
 258     I_DEVB K_DEV <packet>
 259     I_DEVB K_DEV <packet>
 260     <handler-task> drop
 261
 262     I_DEVA 4000 f <device-task> drop
 263     I_DEVB 4000 f <device-task> drop ;
 264
 265 : check ( -- )
 266     qpkt-count 23246 assert=
 267     hold-count 9297 assert= ;
 268
 269 : run ( -- )
 270     init
 271     start
 272     schedule check ;