basis/stack-checker/transforms/transforms.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry accessors arrays kernel kernel.private combinators.private
   4 words sequences generic math math.order namespaces quotations
   5 assocs combinators combinators.short-circuit classes.tuple
   6 classes.tuple.private effects summary hashtables classes sets
   7 definitions generic.standard slots.private continuations locals
   8 sequences.private generalizations stack-checker.backend
   9 stack-checker.state stack-checker.visitor stack-checker.errors
  10 stack-checker.values stack-checker.recursive-state ;
  11 IN: stack-checker.transforms
  12
  13 : call-transformer ( word stack quot -- newquot )
  14     '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
  15     [ transform-expansion-error ]
  16     recover ;
  17
  18 :: ((apply-transform)) ( word quot values stack rstate -- )
  19     rstate recursive-state
  20     [ word stack quot call-transformer ] with-variable
  21     [
  22         values [ length meta-d shorten-by ] [ #drop, ] bi
  23         rstate infer-quot
  24     ] [ word infer-word ] if* ;
  25
  26 : literals? ( values -- ? ) [ literal-value? ] all? ;
  27
  28 : (apply-transform) ( word quot n -- )
  29     ensure-d dup literals? [
  30         dup empty? [ dup recursive-state get ] [
  31             [ ]
  32             [ [ literal value>> ] map ]
  33             [ first literal recursion>> ] tri
  34         ] if
  35         ((apply-transform))
  36     ] [ 2drop infer-word ] if ;
  37
  38 : apply-transform ( word -- )
  39     [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
  40     (apply-transform) ;
  41
  42 : apply-macro ( word -- )
  43     [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
  44     (apply-transform) ;
  45
  46 : define-transform ( word quot n -- )
  47     [ drop "transform-quot" set-word-prop ]
  48     [ nip "transform-n" set-word-prop ]
  49     3bi ;
  50
  51 ! Combinators
  52 \ cond [ cond>quot ] 1 define-transform
  53
  54 \ cond t "no-compile" set-word-prop
  55
  56 \ case [
  57     [
  58         [ no-case ]
  59     ] [
  60         dup peek callable? [
  61             dup peek swap but-last
  62         ] [
  63             [ no-case ] swap
  64         ] if case>quot
  65     ] if-empty
  66 ] 1 define-transform
  67
  68 \ case t "no-compile" set-word-prop
  69
  70 \ cleave [ cleave>quot ] 1 define-transform
  71
  72 \ cleave t "no-compile" set-word-prop
  73
  74 \ 2cleave [ 2cleave>quot ] 1 define-transform
  75
  76 \ 2cleave t "no-compile" set-word-prop
  77
  78 \ 3cleave [ 3cleave>quot ] 1 define-transform
  79
  80 \ 3cleave t "no-compile" set-word-prop
  81
  82 \ spread [ spread>quot ] 1 define-transform
  83
  84 \ spread t "no-compile" set-word-prop
  85
  86 \ (call-next-method) [
  87     [
  88         [ "method-class" word-prop ]
  89         [ "method-generic" word-prop ] bi
  90         [ inlined-dependency depends-on ] bi@
  91     ] [
  92         [ next-method-quot ]
  93         [ '[ _ no-next-method ] ] bi or
  94     ] bi
  95 ] 1 define-transform
  96
  97 \ (call-next-method) t "no-compile" set-word-prop
  98
  99 ! Constructors
 100 \ boa [
 101     dup tuple-class? [
 102         dup inlined-dependency depends-on
 103         [ "boa-check" word-prop [ ] or ]
 104         [ tuple-layout '[ _ <tuple-boa> ] ]
 105         bi append
 106     ] [ drop f ] if
 107 ] 1 define-transform
 108
 109 \ boa t "no-compile" set-word-prop
 110
 111 \ new [
 112     dup tuple-class? [
 113         dup inlined-dependency depends-on
 114         [ all-slots [ initial>> literalize ] map ]
 115         [ tuple-layout '[ _ <tuple-boa> ] ]
 116         bi append
 117     ] [ drop f ] if
 118 ] 1 define-transform
 119
 120 ! Fast at for integer maps
 121 CONSTANT: lookup-table-at-max 256
 122
 123 : lookup-table-at? ( assoc -- ? )
 124     #! Can we use a fast byte array test here?
 125     {
 126         [ assoc-size 4 > ]
 127         [ values [ ] all? ]
 128         [ keys [ integer? ] all? ]
 129         [ keys [ 0 lookup-table-at-max between? ] all? ]
 130     } 1&& ;
 131
 132 : lookup-table-seq ( assoc -- table )
 133     [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
 134
 135 : lookup-table-quot ( seq -- newquot )
 136     lookup-table-seq
 137     '[
 138         _ over integer? [
 139             2dup bounds-check? [
 140                 nth-unsafe dup >boolean
 141             ] [ 2drop f f ] if
 142         ] [ 2drop f f ] if
 143     ] ;
 144
 145 : fast-lookup-table-at? ( assoc -- ? )
 146     values {
 147         [ [ integer? ] all? ]
 148         [ [ 0 254 between? ] all? ]
 149     } 1&& ;
 150
 151 : fast-lookup-table-seq ( assoc -- table )
 152     lookup-table-seq [ 255 or ] B{ } map-as ;
 153
 154 : fast-lookup-table-quot ( seq -- newquot )
 155     fast-lookup-table-seq
 156     '[
 157         _ over integer? [
 158             2dup bounds-check? [
 159                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 160             ] [ 2drop f f ] if
 161         ] [ 2drop f f ] if
 162     ] ;
 163
 164 : at-quot ( assoc -- quot )
 165     dup lookup-table-at? [
 166         dup fast-lookup-table-at? [
 167             fast-lookup-table-quot
 168         ] [
 169             lookup-table-quot
 170         ] if
 171     ] [ drop f ] if ;
 172
 173 \ at* [ at-quot ] 1 define-transform
 174
 175 ! Membership testing
 176 : member-quot ( seq -- newquot )
 177     dup length 4 <= [
 178         [ drop f ] swap
 179         [ literalize [ t ] ] { } map>assoc linear-case-quot
 180     ] [
 181         unique [ key? ] curry
 182     ] if ;
 183
 184 \ member? [
 185     dup sequence? [ member-quot ] [ drop f ] if
 186 ] 1 define-transform
 187
 188 : memq-quot ( seq -- newquot )
 189     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 190     [ drop f ] suffix [ cond ] curry ;
 191
 192 \ memq? [
 193     dup sequence? [ memq-quot ] [ drop f ] if
 194 ] 1 define-transform
 195
 196 ! Index search
 197 \ index [
 198     dup sequence? [
 199         dup length 4 >= [
 200             dup length zip >hashtable '[ _ at ]
 201         ] [ drop f ] if
 202     ] [ drop f ] if
 203 ] 1 define-transform
 204
 205 ! Shuffling
 206 : nths-quot ( indices -- quot )
 207     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 208     '[ _ cleave _ narray ] ;
 209
 210 \ shuffle [
 211     shuffle-mapping nths-quot
 212 ] 1 define-transform