Skip to main content
Code Review

Return to Question

Bumped by Community user
Bumped by Community user
Tweeted twitter.com/#!/StackCodeReview/status/649613241019146240
deleted 16 characters in body; edited tags; edited tags
Source Link
200_success
200_success
  • 144.1k
  • 22
  • 188
  • 473

Syntax highlighting is all messed up, sorry.

-1 cells constant -cell
: cell- -cell + ;

: xchg ( a0 a1 -- ) 2dup @ >r @ swap ! r> swap ! ;

: unguarded_linear_insert ( last val -- )
    >r
    begin cell- dup @ dup r@ > while over cell+ ! repeat
    drop r> swap cell+ !
;

: unguarded_insertion_sort ( first last -- )
    >r
    begin dup r@ <> while dup dup @ unguarded_linear_insert cell+ repeat
    drop rdrop
;

: linear_insert ( first last val -- )
    >r over @ r@ swap <
    if
        begin 2dup <> while cell- dup @ over cell+ ! repeat
        drop r> swap !
    else
        r> unguarded_linear_insert drop
    then
;

: insertion_sort ( first last -- )
    2dup <>
    if
        >r
        dup begin cell+ dup r@ <> while 2dup dup @ linear_insert repeat
        rdrop
    then
    2drop
;


: unguarded_partition ( l f p -- cut )
    >r swap cell-
    begin dup @ r@ > while cell- repeat swap
    begin dup @ r@ < while cell+ repeat swap
    begin 2dup < while
        2dup xchg cell- swap cell+ swap
        begin dup @ r@ > while cell- repeat swap
        begin dup @ r@ < while cell+ repeat swap
    repeat
    swap drop begin dup @ r@ < while cell+ repeat
    rdrop
;

: median_of_3 ( n0 n1 n2 -- n )
    >r 2dup > if swap then
    r> 2dup > if swap then drop
       2dup < if swap then drop
;

: pivot ( l f len -- l f p )
    2 / -cell and over +          ( l f m )
    @ >r over cell- @ over @ r>
    median_of_3
;

: quicksort_loop ( l f t -- )
    begin dup >r -rot 2dup - dup r@ > while
        pivot
        >r 2dup r> unguarded_partition
        >r 2dup + r@ swap r> 2 * < if
            rot over r> recurse swap else
            dup -rot swap r> recurse then
        rot
    repeat
    rdrop 2drop 2drop
;

: quicksort ( l f )
    2dup 2 cells quicksort_loop
    dup 2 cells + dup -rot insertion_sort
    swap unguarded_insertion_sort
;

\ Testing and benchmarking

include random.fs
0 random

: shuffle ( n a -- )
    >r dup
    begin ?dup while 1- 2dup cells r@ + swap rnd swap mod cells r@ + xchg repeat
    rdrop 2drop
;

: fill-i ( n a -- )
    >r
    begin ?dup while 1- dup dup cells r@ + ! repeat
    rdrop
;

: fill-ir ( n a )
    begin 2dup ! cell+ swap 1- ?dup while swap repeat drop
;

1024 1024 * constant total-size
variable data total-size cells allocate throw data !
total-size data @ fill-i
total-size data @ shuffle
variable ssrt total-size cells allocate throw ssrt !

: exetime  utime 2>r quicksort execute  utime 2r> d- ." dtime " . cr ;

variable size 16 size !
variable logs  4 logs !

: run ( fp )
    >r
    begin total-size size @ >= while
        data @ ssrt @ size @ cells move
        ssrt @ size @ cells + ssrt @
        size @ . cr
        .s cr
        r@ hex. cr
        r@ exetime
        size @ . size @ m*/
        size @ 2 * size !
    repeat
    rdrop
;

' quicksort run
bye

-1 cells constant -cell
: cell- -cell + ;

: xchg ( a0 a1 -- ) 2dup @ >r @ swap ! r> swap ! ;

: unguarded_linear_insert ( last val -- )
    >r
    begin cell- dup @ dup r@ > while over cell+ ! repeat
    drop r> swap cell+ !
;

: unguarded_insertion_sort ( first last -- )
    >r
    begin dup r@ <> while dup dup @ unguarded_linear_insert cell+ repeat
    drop rdrop
;

: linear_insert ( first last val -- )
    >r over @ r@ swap <
    if
        begin 2dup <> while cell- dup @ over cell+ ! repeat
        drop r> swap !
    else
        r> unguarded_linear_insert drop
    then
;

: insertion_sort ( first last -- )
    2dup <>
    if
        >r
        dup begin cell+ dup r@ <> while 2dup dup @ linear_insert repeat
        rdrop
    then
    2drop
;


: unguarded_partition ( l f p -- cut )
    >r swap cell-
    begin dup @ r@ > while cell- repeat swap
    begin dup @ r@ < while cell+ repeat swap
    begin 2dup < while
        2dup xchg cell- swap cell+ swap
        begin dup @ r@ > while cell- repeat swap
        begin dup @ r@ < while cell+ repeat swap
    repeat
    swap drop begin dup @ r@ < while cell+ repeat
    rdrop
;

: median_of_3 ( n0 n1 n2 -- n )
    >r 2dup > if swap then
    r> 2dup > if swap then drop
       2dup < if swap then drop
;

: pivot ( l f len -- l f p )
    2 / -cell and over +          ( l f m )
    @ >r over cell- @ over @ r>
    median_of_3
;

: quicksort_loop ( l f t -- )
    begin dup >r -rot 2dup - dup r@ > while
        pivot
        >r 2dup r> unguarded_partition
        >r 2dup + r@ swap r> 2 * < if
            rot over r> recurse swap else
            dup -rot swap r> recurse then
        rot
    repeat
    rdrop 2drop 2drop
;

: quicksort ( l f )
    2dup 2 cells quicksort_loop
    dup 2 cells + dup -rot insertion_sort
    swap unguarded_insertion_sort
;

\ Testing and benchmarking

include random.fs
0 random

: shuffle ( n a -- )
    >r dup
    begin ?dup while 1- 2dup cells r@ + swap rnd swap mod cells r@ + xchg repeat
    rdrop 2drop
;

: fill-i ( n a -- )
    >r
    begin ?dup while 1- dup dup cells r@ + ! repeat
    rdrop
;

: fill-ir ( n a )
    begin 2dup ! cell+ swap 1- ?dup while swap repeat drop
;

1024 1024 * constant total-size
variable data total-size cells allocate throw data !
total-size data @ fill-i
total-size data @ shuffle
variable ssrt total-size cells allocate throw ssrt !

: exetime  utime 2>r quicksort execute  utime 2r> d- ." dtime " . cr ;

variable size 16 size !
variable logs  4 logs !

: run ( fp )
    >r
    begin total-size size @ >= while
        data @ ssrt @ size @ cells move
        ssrt @ size @ cells + ssrt @
        size @ . cr
        .s cr
        r@ hex. cr
        r@ exetime
        size @ . size @ m*/
        size @ 2 * size !
    repeat
    rdrop
;

' quicksort run
bye

Syntax highlighting is all messed up, sorry.

-1 cells constant -cell
: cell- -cell + ;

: xchg ( a0 a1 -- ) 2dup @ >r @ swap ! r> swap ! ;

: unguarded_linear_insert ( last val -- )
    >r
    begin cell- dup @ dup r@ > while over cell+ ! repeat
    drop r> swap cell+ !
;

: unguarded_insertion_sort ( first last -- )
    >r
    begin dup r@ <> while dup dup @ unguarded_linear_insert cell+ repeat
    drop rdrop
;

: linear_insert ( first last val -- )
    >r over @ r@ swap <
    if
        begin 2dup <> while cell- dup @ over cell+ ! repeat
        drop r> swap !
    else
        r> unguarded_linear_insert drop
    then
;

: insertion_sort ( first last -- )
    2dup <>
    if
        >r
        dup begin cell+ dup r@ <> while 2dup dup @ linear_insert repeat
        rdrop
    then
    2drop
;


: unguarded_partition ( l f p -- cut )
    >r swap cell-
    begin dup @ r@ > while cell- repeat swap
    begin dup @ r@ < while cell+ repeat swap
    begin 2dup < while
        2dup xchg cell- swap cell+ swap
        begin dup @ r@ > while cell- repeat swap
        begin dup @ r@ < while cell+ repeat swap
    repeat
    swap drop begin dup @ r@ < while cell+ repeat
    rdrop
;

: median_of_3 ( n0 n1 n2 -- n )
    >r 2dup > if swap then
    r> 2dup > if swap then drop
       2dup < if swap then drop
;

: pivot ( l f len -- l f p )
    2 / -cell and over +          ( l f m )
    @ >r over cell- @ over @ r>
    median_of_3
;

: quicksort_loop ( l f t -- )
    begin dup >r -rot 2dup - dup r@ > while
        pivot
        >r 2dup r> unguarded_partition
        >r 2dup + r@ swap r> 2 * < if
            rot over r> recurse swap else
            dup -rot swap r> recurse then
        rot
    repeat
    rdrop 2drop 2drop
;

: quicksort ( l f )
    2dup 2 cells quicksort_loop
    dup 2 cells + dup -rot insertion_sort
    swap unguarded_insertion_sort
;

\ Testing and benchmarking

include random.fs
0 random

: shuffle ( n a -- )
    >r dup
    begin ?dup while 1- 2dup cells r@ + swap rnd swap mod cells r@ + xchg repeat
    rdrop 2drop
;

: fill-i ( n a -- )
    >r
    begin ?dup while 1- dup dup cells r@ + ! repeat
    rdrop
;

: fill-ir ( n a )
    begin 2dup ! cell+ swap 1- ?dup while swap repeat drop
;

1024 1024 * constant total-size
variable data total-size cells allocate throw data !
total-size data @ fill-i
total-size data @ shuffle
variable ssrt total-size cells allocate throw ssrt !

: exetime  utime 2>r quicksort execute  utime 2r> d- ." dtime " . cr ;

variable size 16 size !
variable logs  4 logs !

: run ( fp )
    >r
    begin total-size size @ >= while
        data @ ssrt @ size @ cells move
        ssrt @ size @ cells + ssrt @
        size @ . cr
        .s cr
        r@ hex. cr
        r@ exetime
        size @ . size @ m*/
        size @ 2 * size !
    repeat
    rdrop
;

' quicksort run
bye

-1 cells constant -cell
: cell- -cell + ;

: xchg ( a0 a1 -- ) 2dup @ >r @ swap ! r> swap ! ;

: unguarded_linear_insert ( last val -- )
    >r
    begin cell- dup @ dup r@ > while over cell+ ! repeat
    drop r> swap cell+ !
;

: unguarded_insertion_sort ( first last -- )
    >r
    begin dup r@ <> while dup dup @ unguarded_linear_insert cell+ repeat
    drop rdrop
;

: linear_insert ( first last val -- )
    >r over @ r@ swap <
    if
        begin 2dup <> while cell- dup @ over cell+ ! repeat
        drop r> swap !
    else
        r> unguarded_linear_insert drop
    then
;

: insertion_sort ( first last -- )
    2dup <>
    if
        >r
        dup begin cell+ dup r@ <> while 2dup dup @ linear_insert repeat
        rdrop
    then
    2drop
;


: unguarded_partition ( l f p -- cut )
    >r swap cell-
    begin dup @ r@ > while cell- repeat swap
    begin dup @ r@ < while cell+ repeat swap
    begin 2dup < while
        2dup xchg cell- swap cell+ swap
        begin dup @ r@ > while cell- repeat swap
        begin dup @ r@ < while cell+ repeat swap
    repeat
    swap drop begin dup @ r@ < while cell+ repeat
    rdrop
;

: median_of_3 ( n0 n1 n2 -- n )
    >r 2dup > if swap then
    r> 2dup > if swap then drop
       2dup < if swap then drop
;

: pivot ( l f len -- l f p )
    2 / -cell and over +          ( l f m )
    @ >r over cell- @ over @ r>
    median_of_3
;

: quicksort_loop ( l f t -- )
    begin dup >r -rot 2dup - dup r@ > while
        pivot
        >r 2dup r> unguarded_partition
        >r 2dup + r@ swap r> 2 * < if
            rot over r> recurse swap else
            dup -rot swap r> recurse then
        rot
    repeat
    rdrop 2drop 2drop
;

: quicksort ( l f )
    2dup 2 cells quicksort_loop
    dup 2 cells + dup -rot insertion_sort
    swap unguarded_insertion_sort
;

\ Testing and benchmarking

include random.fs
0 random

: shuffle ( n a -- )
    >r dup
    begin ?dup while 1- 2dup cells r@ + swap rnd swap mod cells r@ + xchg repeat
    rdrop 2drop
;

: fill-i ( n a -- )
    >r
    begin ?dup while 1- dup dup cells r@ + ! repeat
    rdrop
;

: fill-ir ( n a )
    begin 2dup ! cell+ swap 1- ?dup while swap repeat drop
;

1024 1024 * constant total-size
variable data total-size cells allocate throw data !
total-size data @ fill-i
total-size data @ shuffle
variable ssrt total-size cells allocate throw ssrt !

: exetime  utime 2>r quicksort execute  utime 2r> d- ." dtime " . cr ;

variable size 16 size !
variable logs  4 logs !

: run ( fp )
    >r
    begin total-size size @ >= while
        data @ ssrt @ size @ cells move
        ssrt @ size @ cells + ssrt @
        size @ . cr
        .s cr
        r@ hex. cr
        r@ exetime
        size @ . size @ m*/
        size @ 2 * size !
    repeat
    rdrop
;

' quicksort run
bye
Source Link
vnp
vnp
  • 57.3k
  • 4
  • 51
  • 140

Forth to the past - qsort

To make a long story short, I must revive my Forth. It is rusty; last time I did anything serious in Forth was 30 years ago (man, I am old). As an exercise, I translated an STL-like implementation of qsort. It works (if you want to test it, install gforth). It performs well comparing to SDCC-compiled native C (I don't have Keil license). I know where my bottlenecks are.

I am mostly interested in how readable the code is; how much did I sin against Forth spirit; if there are modern Forth coding conventions, how does this code fare.

Syntax highlighting is all messed up, sorry.

-1 cells constant -cell
: cell- -cell + ;

: xchg ( a0 a1 -- ) 2dup @ >r @ swap ! r> swap ! ;

: unguarded_linear_insert ( last val -- )
    >r
    begin cell- dup @ dup r@ > while over cell+ ! repeat
    drop r> swap cell+ !
;

: unguarded_insertion_sort ( first last -- )
    >r
    begin dup r@ <> while dup dup @ unguarded_linear_insert cell+ repeat
    drop rdrop
;

: linear_insert ( first last val -- )
    >r over @ r@ swap <
    if
        begin 2dup <> while cell- dup @ over cell+ ! repeat
        drop r> swap !
    else
        r> unguarded_linear_insert drop
    then
;

: insertion_sort ( first last -- )
    2dup <>
    if
        >r
        dup begin cell+ dup r@ <> while 2dup dup @ linear_insert repeat
        rdrop
    then
    2drop
;


: unguarded_partition ( l f p -- cut )
    >r swap cell-
    begin dup @ r@ > while cell- repeat swap
    begin dup @ r@ < while cell+ repeat swap
    begin 2dup < while
        2dup xchg cell- swap cell+ swap
        begin dup @ r@ > while cell- repeat swap
        begin dup @ r@ < while cell+ repeat swap
    repeat
    swap drop begin dup @ r@ < while cell+ repeat
    rdrop
;

: median_of_3 ( n0 n1 n2 -- n )
    >r 2dup > if swap then
    r> 2dup > if swap then drop
       2dup < if swap then drop
;

: pivot ( l f len -- l f p )
    2 / -cell and over +          ( l f m )
    @ >r over cell- @ over @ r>
    median_of_3
;

: quicksort_loop ( l f t -- )
    begin dup >r -rot 2dup - dup r@ > while
        pivot
        >r 2dup r> unguarded_partition
        >r 2dup + r@ swap r> 2 * < if
            rot over r> recurse swap else
            dup -rot swap r> recurse then
        rot
    repeat
    rdrop 2drop 2drop
;

: quicksort ( l f )
    2dup 2 cells quicksort_loop
    dup 2 cells + dup -rot insertion_sort
    swap unguarded_insertion_sort
;

\ Testing and benchmarking

include random.fs
0 random

: shuffle ( n a -- )
    >r dup
    begin ?dup while 1- 2dup cells r@ + swap rnd swap mod cells r@ + xchg repeat
    rdrop 2drop
;

: fill-i ( n a -- )
    >r
    begin ?dup while 1- dup dup cells r@ + ! repeat
    rdrop
;

: fill-ir ( n a )
    begin 2dup ! cell+ swap 1- ?dup while swap repeat drop
;

1024 1024 * constant total-size
variable data total-size cells allocate throw data !
total-size data @ fill-i
total-size data @ shuffle
variable ssrt total-size cells allocate throw ssrt !

: exetime  utime 2>r quicksort execute  utime 2r> d- ." dtime " . cr ;

variable size 16 size !
variable logs  4 logs !

: run ( fp )
    >r
    begin total-size size @ >= while
        data @ ssrt @ size @ cells move
        ssrt @ size @ cells + ssrt @
        size @ . cr
        .s cr
        r@ hex. cr
        r@ exetime
        size @ . size @ m*/
        size @ 2 * size !
    repeat
    rdrop
;

' quicksort run
bye