basis/sequences/unrolled/unrolled.factor

   1 ! Copyright (C) 2010 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators combinators.short-circuit
   4 compiler.tree.propagation.transforms kernel math
   5 sequences sequences.private ;
   6 IN: sequences.unrolled
   7
   8 <PRIVATE
   9 : (unrolled-each-integer) ( quot n -- )
  10     swap '[ _ call( i -- ) ] each-integer ;
  11
  12 << \ (unrolled-each-integer) [
  13     <iota> [ '[ _ swap call( i -- ) ] ] [ ] map-as '[ _ cleave ]
  14 ] 1 define-partial-eval >>
  15
  16 : (unrolled-collect) ( quot into -- quot' )
  17     '[ dup @ swap _ set-nth-unsafe ] ; inline
  18
  19 PRIVATE>
  20
  21 : unrolled-each-integer ( n quot: ( i -- ) -- )
  22     swap (unrolled-each-integer) ; inline
  23
  24 : unrolled-collect ( n quot: ( n -- value ) into -- )
  25     (unrolled-collect) unrolled-each-integer ; inline
  26
  27 : unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq )
  28     overd [ [ unrolled-collect ] keep ] new-like ; inline
  29
  30 ERROR: unrolled-bounds-error
  31     seq unroll-length ;
  32
  33 ERROR: unrolled-2bounds-error
  34     xseq yseq unroll-length ;
  35
  36 <PRIVATE
  37 : unrolled-bounds-check ( seq len quot -- seq len quot )
  38     2over swap length > [ 2over unrolled-bounds-error ] when ; inline
  39
  40 :: unrolled-2bounds-check ( xseq yseq len quot -- xseq yseq len quot )
  41     { [ len xseq length > ] [ len yseq length > ] } 0||
  42     [ xseq yseq len unrolled-2bounds-error ]
  43     [ xseq yseq len quot ] if ; inline
  44
  45 : (unrolled-each) ( seq len quot -- len quot )
  46     swapd '[ _ nth-unsafe @ ] ; inline
  47
  48 : (unrolled-each-index) ( seq len quot -- len quot )
  49     swapd '[ dup _ nth-unsafe swap @ ] ; inline
  50
  51 : (unrolled-2each) ( xseq yseq len quot -- len quot )
  52     [ '[ _ ] 2dip ] dip (2each) nip ; inline
  53
  54 : unrolled-each-unsafe ( seq len quot: ( x -- ) -- )
  55     (unrolled-each) unrolled-each-integer ; inline
  56
  57 : unrolled-2each-unsafe ( xseq yseq len quot: ( x y -- ) -- )
  58     (unrolled-2each) unrolled-each-integer ; inline
  59
  60 : unrolled-each-index-unsafe ( seq len quot: ( x -- ) -- )
  61     (unrolled-each-index) unrolled-each-integer ; inline
  62
  63 : unrolled-map-as-unsafe ( seq len quot: ( x -- newx ) exemplar -- newseq )
  64     [ (unrolled-each) ] dip unrolled-map-integers ; inline
  65
  66 : unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
  67     [ (unrolled-2each) ] dip unrolled-map-integers ; inline
  68
  69 : unrolled-map-unsafe ( seq len quot: ( x -- newx ) -- newseq )
  70     pick unrolled-map-as-unsafe ; inline
  71
  72 : unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
  73     reach unrolled-2map-as-unsafe ; inline
  74
  75 PRIVATE>
  76
  77 : unrolled-each ( seq len quot: ( x -- ) -- )
  78     unrolled-bounds-check unrolled-each-unsafe ; inline
  79
  80 : unrolled-2each ( xseq yseq len quot: ( x y -- ) -- )
  81     unrolled-2bounds-check unrolled-2each-unsafe ; inline
  82
  83 : unrolled-each-index ( seq len quot: ( x i -- ) -- )
  84     unrolled-bounds-check unrolled-each-index-unsafe ; inline
  85
  86 : unrolled-map-as ( seq len quot: ( x -- newx ) exemplar -- newseq )
  87     [ unrolled-bounds-check ] dip unrolled-map-as-unsafe ; inline
  88
  89 : unrolled-2map-as ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
  90     [ unrolled-2bounds-check ] dip unrolled-2map-as-unsafe ; inline
  91
  92 : unrolled-map ( seq len quot: ( x -- newx ) -- newseq )
  93     pick unrolled-map-as ; inline
  94
  95 : unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq )
  96     reach unrolled-2map-as ; inline
  97
  98 : unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
  99     [ dup length <iota> ] 2dip unrolled-2map ; inline