Fortran proves Forth a stone-age toy

From	"WJ" <w_a_x_man@yahoo.com>
Newsgroups	comp.lang.forth
Subject	Fortran proves Forth a stone-age toy
Date	2013-07-09 07:14 +0000
Organization	A noiseless patient Spider
Message-ID	<krgd8b$vji$1@dont-email.me> (permalink)

Show all headers | View raw

I threw together a Fortran version of the Fannkuch program that
runs in only 0.203 seconds on my tired, old, battered laptop.

That leaves the iForth version in the dust.

In addition, the Fortran program is immeasurably more readable
and maintainable.




! 0.203125000 seconds on Intel Core2 Duo CPU P8600 @ 2.4GHz

! GFortran (gcc version 4.8.0 20130302)
! Compile with
! gfortran -O3 -march=native fannkuch.f95

program fannkuch
  implicit none
  integer, parameter :: N = 10
  integer :: perm(N), permp(N), counts(N), tmp, i, flips
  integer :: maxflips = 0, prn_count = 0, r = N
  real :: t1, t2

  call cpu_time( t1 )

  do i = 1, N
    permp(i) = i
    counts(i) = 0
  end do

  do while (.true.)
    if (prn_count < 30) then
      prn_count = prn_count + 1
      call print_vector( permp )
    end if
    do i = 2, r
      counts(i) = i
    end do
    r = 1

    if ( permp(1) /= 1  .and.  permp(N) /= N  ) then
      perm = permp
      flips = flipping( perm )
      if (flips > maxflips) maxflips = flips
    end if

    do while (.true.)
      if (N == r) then
        print "(A:,I0,A:,I0)", "Pfannkuchen(", N, ") = ", maxflips
        call cpu_time( t2 )
        print *, t2 - t1
        stop
      end if
      i = r + 1

      ! ---  Shift left.
      tmp = permp(1)
      permp(1:i-1) = permp(2:i)
      permp(i) = tmp

      counts(i) = counts(i) - 1
      if (counts(i) > 0)  exit
      r = r + 1
    end do

  end do

  contains

  integer function flipping( perm )
    implicit none
    integer :: perm(N)
    integer :: k, tmp, flips
    flips = 0
    k = perm(1)
    do while (k > 1)
        ! --- Reverse part.
      if (k > 3) call reverse_some( perm, k - 1 )
      flips = flips + 1
      tmp = perm(k)
      perm(k) = k
      k = tmp
    end do
    flipping = flips
  end function flipping

  subroutine print_vector( v )
    implicit none
    integer :: v(N), i
    do i = 1, ubound(v,1)
      write (*, "(I0)", advance="no"), v(i)
    end do
    print *, ""
  end subroutine

  subroutine reverse_some( vector, top )
    implicit none
    integer :: vector(N), top, i, j, tmp
    i = 2
    j = top
    do while (i < j)
      tmp = vector( i )
      vector( i ) = vector( j )
      vector( j ) = tmp
      j = j - 1
      i = i + 1
    end do
  end

end program fannkuch






> From: mhx@iae.nl (Marcel Hendrix)
> Subject: Pfannkuch revisited
> Date: Wed, 26 Dec 2012 10:06:52 +0200
> Message-ID: <83979309918435@frunobulax.edu>
> Lines: 180
> 
> Pfannkuch (Computer Language Shootout) was mentioned recently ... 
> 
> Back in 2006 I wasn't happy that 580 ms was the best 
> iForth could do, compared to 330 ms in 'C'.
> 
> Tonight I looked at it again. Based on Stephen Pelc's remarks I removed 
> all local variables -- that shaved off about 100 ms. Doing the I/O
> differently speeded it up another 100 ms. The Forth and C version now 
> behave nearly the same. The C version is using ints where Forth uses bytes.
> Timings are done on the same machine, I recompiled and optimized the C 
> version as good as it would go. (It is a 64bit program, but ints are 32 bits
> on Windows).
> 
> -marcel
> 
> -- -------------------------------------------
> (*
>  * LANGUAGE    : ANS Forth with extensions
>  * PROJECT     : Forth Environments
>  * DESCRIPTION : Fannkuch benchmark
>  * CATEGORY    : Benchmarks
>  * AUTHOR      : Marcel Hendrix 
>  * LAST CHANGE : June 10, 2006, Marcel Hendrix 
>  * LAST CHANGE : Wednesday, December 26, 2012, 00:12, Marcel Hendrix 
>  *)
> 
> 
> 	NEEDS -miscutil
> 
> 	REVISION -fannkuch5 "--- Fannkuch (C)        Version 5.00 ---"
> 
> 
> DOC
> (*
>  fannkuch benchmark | C gcc | fannkuch full data 
> 
>  fannkuch C gcc program
>  N  Full CPU Time s   Memory Use KB   GZip Bytes 
>  10      0.45              16,384         612 
> 
> /*
>  * The Computer Language Shootout
>  * http://shootout.alioth.debian.org/
>  * Contributed by Heiner Marxen
>  *
>  * "fannkuch"	for C gcc
>  *
>  * $Id: fannkuch-gcc.code,v 1.33 2006/02/25 16:38:58 igouy-guest Exp $
>  */
> 
> 	PROGRAM OUTPUT
> 	==============
> 	12345678910
> 	21345678910
> 	23145678910
> 	32145678910
> 	31245678910
> 	13245678910
> 	23415678910
> 	32415678910
> 	34215678910
> 	43215678910
> 	42315678910
> 	24315678910
> 	34125678910
> 	43125678910
> 	41325678910
> 	14325678910
> 	13425678910
> 	31425678910
> 	41235678910
> 	14235678910
> 	12435678910
> 	21435678910
> 	24135678910
> 	42135678910
> 	23451678910
> 	32451678910
> 	34251678910
> 	43251678910
> 	42351678910
> 	24351678910
> 	Pfannkuchen(10) = 38
> *)
> ENDDOC
> 
>  #10 =: N
> N 1- =: N1
> 
> CREATE perm   N ALLOT 
> CREATE perm1  N ALLOT
> CREATE counts N ALLOT
> 
> 0 VALUE didpr
> 0 VALUE flips
> 0 VALUE flipsMax
> 
> CREATE obuffer #4096 CHARS ALLOT
> 
> : oinit ( -- ) obuffer 0! ;
> : >out ( c-addr u -- ) obuffer CELLPLACE+ ;
> : CR>out ( -- ) $CR COUNT >out ;
> : .pan ( -- ) CR>out  N 0 DO  perm1 I + C@ 1+ (0DEC.R) >out  LOOP ;
> 
> : XCH ( ix1 ix2 -- ) 
> 	perm + SWAP perm + 
> 	DUP C@ >R  SWAP DUP C@ ( -- addr1 addr2 n2 )
> 	ROT C!  R> SWAP C! ;
> 
> -- N = 10
> 64BIT? 
>   [IF]
> : special-move ( -- )
> 	  perm1 1+   @   perm 1+   !
> 	  perm1 9 + C@   perm 9 + C! ; 
> [ELSE]
> : special-move ( -- )
> 	  perm1 1+   @   perm 1+   !
> 	  perm1 5 +  @   perm 5 +  ! 
> 	  perm1 9 + C@   perm 9 + C! ; 
> [THEN]
> 
> : fannkuch ( -- u )
> 	N 1 < IF  0 EXIT  ENDIF
> 	CLEAR didpr CLEAR flips CLEAR flipsMaX
> 	N >R
> 	perm1 N 0 DO  I SWAP C!+  LOOP	DROP \ initial (trivial) permute 
> 	BEGIN
> 		didpr #30 < IF  .pan 1 +TO didpr  ENDIF
> 
> 		counts R@ 1- + R>
> 		BEGIN  DUP 1 <>  
> 		WHILE  DUP 2 PICK C!  
> 		       1-   SWAP 1- SWAP
> 		REPEAT >R DROP
> 
> 		perm1 C@ 0=  
> 		perm1 N1 + C@ N1 = OR  0= 
> 		   IF  	0 TO flips
> 			special-move 
> 			perm1 C@ >R			\ cache perm[0] on R
> 			BEGIN				\ k1 != 0 ==> k1>0 
> 				1  R@ 1-     	( -- i1 j1 )
> 				BEGIN	2DUP <
> 				WHILE 	2DUP XCH
> 					1- SWAP 1+ SWAP
> 				REPEAT  2DROP
> 				R> DUP perm + DUP C@ >R C! ( R: -- j1 )  
> 				1 +TO flips
> 				R@ 0=
> 			UNTIL 	-R
> 			flipsMax flips < IF  flips TO flipsMax  ENDIF
> 		ENDIF
> 		BEGIN  R@ N = IF  flipsMax -R EXIT  ENDIF \ rotate down perm[0..r] by one 
> 		       perm1 C@ ( perm0)  0 
> 		       BEGIN  DUP R@ <
> 		       WHILE  1+ 
> 		              DUP perm1 +  DUP C@  SWAP 1- C!
> 		       REPEAT DROP ( perm0)  
> 		       perm1  R@ + C!
> 		       counts R@ + DUP C@ 1-  DUP ROT C!  0<=
> 		WHILE  R> 1+ >R
> 		REPEAT
> 	AGAIN ;
> 
> : main ( -- ) 
> 	oinit
> 	TIMER-RESET 
> 	 fannkuch 
> 	 CR>out S" Pfannkuchen(" >out N (0DEC.R) >out S" ) = " >out (.) >out 
> 	CR .ELAPSED 
> 	obuffer @+ TYPE ;
> 
> :ABOUT	CR ." Try: main -- Standard Shootout test (VC++ 6.0: 333 ms). Should be around 352 ms." 
> 	CR ." Using TYPE gives 450 ms."  ;
> 
> 		.ABOUT -fannkuch5 CR
> 
>                               (* End of Source *)
>

Back to comp.lang.forth | Previous | Next — Next in thread | Find similar

Thread

Fortran proves Forth a stone-age toy "WJ" <w_a_x_man@yahoo.com> - 2013-07-09 07:14 +0000
  Re: Fortran proves Forth a stone-age toy m.a.m.hendrix@tue.nl - 2013-07-09 01:03 -0700
  Re: Fortran proves Forth a stone-age toy "Ed" <invalid@invalid.com> - 2013-07-09 19:32 +1000
  Re: Fortran proves Forth a stone-age toy "WJ" <w_a_x_man@yahoo.com> - 2013-07-09 22:26 +0000
    Re: Fortran proves Forth a stone-age toy "WJ" <w_a_x_man@yahoo.com> - 2013-07-11 00:01 +0000
      Re: Fortran proves Forth a stone-age toy "WJ" <w_a_x_man@yahoo.com> - 2013-07-12 12:10 +0000
  Re: Fortran proves Forth a stone-age toy hughaguilar96@yahoo.com - 2013-07-10 11:10 -0700
    Re: Fortran proves Forth a stone-age toy "Rod Pemberton" <do_not_have@notemailnotq.cpm> - 2013-07-12 03:14 -0400
      Re: Fortran proves Forth a stone-age toy Richard Owlett <rowlett@pcnetinc.com> - 2013-07-12 05:14 -0500

csiph-web