perf_dupdrop.f

   1 ( -*- text -*-
   2   FORTH repeated DUP DROP * 1000 using ordinary indirect threaded code
   3   and the assembler primitives.
   4   $Id: perf_dupdrop.f,v 1.3 2007-10-12 01:46:26 rich Exp $ )
   5
   6 1024 32 * MORECORE
   7
   8 ( Print the time passed. )
   9 : PRINT-TIME    ( lsb msb lsb msb -- lsb lsb )
  10         ( The test is very short so likely the MSBs will be the same.  This
  11           makes calculating the time easier (because we can only do 32 bit
  12             subtraction).  So check MSBs are equal. )
  13         2 PICK <> IF
  14                 ." MSBs not equal, please repeat the test" CR
  15         ELSE
  16                 NIP
  17                 SWAP - U. CR
  18         THEN
  19 ;
  20
  21 : 4DROP DROP DROP DROP DROP ;
  22
  23 : PERFORM-TEST  ( xt -- )
  24         ( Get everything in the cache. )
  25         DUP EXECUTE 4DROP
  26         DUP EXECUTE 4DROP
  27         DUP EXECUTE 4DROP
  28         DUP EXECUTE 4DROP
  29         DUP EXECUTE 4DROP
  30         DUP EXECUTE 4DROP
  31         0 0 0 0 PRINT-TIME
  32         ( Run the test 10 times. )
  33         DUP EXECUTE PRINT-TIME
  34         DUP EXECUTE PRINT-TIME
  35         DUP EXECUTE PRINT-TIME
  36         DUP EXECUTE PRINT-TIME
  37         DUP EXECUTE PRINT-TIME
  38         DUP EXECUTE PRINT-TIME
  39         DUP EXECUTE PRINT-TIME
  40         DUP EXECUTE PRINT-TIME
  41         DUP EXECUTE PRINT-TIME
  42         DUP EXECUTE PRINT-TIME
  43         DROP
  44 ;
  45
  46 ( ---------------------------------------------------------------------- )
  47 ( Make a word which builds the repeated DUP DROP sequence. )
  48 : MAKE-DUPDROP  ( n -- )
  49         BEGIN ?DUP WHILE ' DUP , ' DROP , 1- REPEAT
  50 ;
  51
  52 ( Now the actual test routine. )
  53 : TEST          ( -- startlsb startmsb endlsb endmsb )
  54         RDTSC                   ( Start time )
  55         [ 1000 MAKE-DUPDROP ]   ( 1000 * DUP DROP )
  56         RDTSC                   ( End time )
  57 ;
  58
  59 : RUN ['] TEST PERFORM-TEST ;
  60 RUN
  61
  62 ( ---------------------------------------------------------------------- )
  63 ( Try the inlined alternative. )
  64
  65 ( Inline the assembler primitive (cfa) n times. )
  66 : *(INLINE) ( cfa n -- )
  67         BEGIN ?DUP WHILE OVER (INLINE) 1- REPEAT DROP
  68 ;
  69
  70 : DUPDROP INLINE DUP INLINE DROP ;CODE
  71
  72 : TEST
  73         INLINE RDTSC
  74         [ S" DUPDROP" FIND >CFA 1000 *(INLINE) ]
  75         INLINE RDTSC
  76 ;CODE
  77
  78 : RUN ['] TEST PERFORM-TEST ;
  79 RUN