basis/hints/hints.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays byte-vectors classes
   4 combinators definitions effects fry generic generic.single
   5 generic.standard hashtables io.binary io.streams.string kernel
   6 kernel.private math math.parser namespaces parser sbufs
   7 sequences splitting splitting.private strings vectors words ;
   8 IN: hints
   9
  10 GENERIC: specializer-predicate ( spec -- quot )
  11
  12 M: class specializer-predicate "predicate" word-prop ;
  13
  14 M: object specializer-predicate '[ _ eq? ] ;
  15
  16 GENERIC: specializer-declaration ( spec -- class )
  17
  18 M: class specializer-declaration ;
  19
  20 M: object specializer-declaration class ;
  21
  22 : specialized? ( types -- ? )
  23     [ object = ] all? not ;
  24
  25 : specializer ( word -- specializer )
  26     [ "specializer" word-prop ]
  27     [ stack-effect effect-in-types ] bi
  28     dup specialized? [ suffix ] [ drop ] if ;
  29
  30 : make-specializer ( specs -- quot )
  31     dup length <reversed>
  32     [ (picker) 2array ] 2map
  33     [ drop object eq? not ] assoc-filter
  34     [ [ t ] ] [
  35         [ swap specializer-predicate append ] { } assoc>map
  36         [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
  37     ] if-empty ;
  38
  39 : specializer-cases ( quot word -- default alist )
  40     dup [ array? ] all? [ 1array ] unless [
  41         [ make-specializer ] keep
  42         [ specializer-declaration ] map '[ _ declare ] pick append
  43     ] { } map>assoc ;
  44
  45 : specialize-quot ( quot specializer -- quot' )
  46     specializer-cases alist>quot ;
  47
  48 ! compiler.tree.propagation.inlining sets this to f
  49 SYMBOL: specialize-method?
  50
  51 t specialize-method? set-global
  52
  53 : method-declaration ( method -- quot )
  54     [ "method-generic" word-prop dispatch# object <array> ]
  55     [ "method-class" word-prop ]
  56     bi prefix [ declare ] curry [ ] like ;
  57
  58 : specialize-method ( quot method -- quot' )
  59     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
  60     [ "method-generic" word-prop specializer ] bi
  61     [ specialize-quot ] when* ;
  62
  63 : standard-method? ( method -- ? )
  64     dup method-body? [
  65         "method-generic" word-prop standard-generic?
  66     ] [ drop f ] if ;
  67
  68 : specialized-def ( word -- quot )
  69     [ def>> ] keep
  70     dup generic? [ drop ] [
  71         [ dup standard-method? [ specialize-method ] [ drop ] if ]
  72         [ specializer [ specialize-quot ] when* ]
  73         bi
  74     ] if ;
  75
  76 : specialized-length ( specializer -- n )
  77     dup [ array? ] all? [ first ] when length ;
  78
  79 SYNTAX: HINTS:
  80     scan-object dup wrapper? [ wrapped>> ] when
  81     [ changed-definition ]
  82     [ subwords [ changed-definition ] each ]
  83     [ parse-definition { } like "specializer" set-word-prop ] tri ;
  84
  85 ! Default specializers
  86 { first first2 first3 first4 }
  87 [ { array } "specializer" set-word-prop ] each
  88
  89 { last pop* pop } [
  90     { vector } "specializer" set-word-prop
  91 ] each
  92
  93 \ push { { vector } { sbuf } } "specializer" set-word-prop
  94
  95 \ last { { vector } } "specializer" set-word-prop
  96
  97 \ set-last { { object vector } } "specializer" set-word-prop
  98
  99 \ push-all
 100 { { string sbuf } { array vector } { byte-array byte-vector } }
 101 "specializer" set-word-prop
 102
 103 \ append
 104 { { string string } { array array } }
 105 "specializer" set-word-prop
 106
 107 \ subseq
 108 { { fixnum fixnum string } { fixnum fixnum array } }
 109 "specializer" set-word-prop
 110
 111 \ reverse-here
 112 { { string } { array } }
 113 "specializer" set-word-prop
 114
 115 \ mismatch
 116 { string string }
 117 "specializer" set-word-prop
 118
 119 \ >string { sbuf } "specializer" set-word-prop
 120
 121 \ >array { { vector } } "specializer" set-word-prop
 122
 123 \ >vector { { array } { vector } } "specializer" set-word-prop
 124
 125 \ >sbuf { string } "specializer" set-word-prop
 126
 127 \ split, { string string } "specializer" set-word-prop
 128
 129 \ memq? { array } "specializer" set-word-prop
 130
 131 \ member? { array } "specializer" set-word-prop
 132
 133 \ assoc-stack { vector } "specializer" set-word-prop
 134
 135 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
 136
 137 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
 138
 139 \ base> { string fixnum } "specializer" set-word-prop
 140
 141 M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
 142
 143 M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop