basis/sequences/unrolled/unrolled.factor

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