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 : specializer ( word -- specializer )
  23     "specializer" word-prop ;
  24
  25 : make-specializer ( specs -- quot )
  26     dup length <reversed>
  27     [ (picker) 2array ] 2map
  28     [ drop object eq? not ] assoc-filter
  29     [ [ t ] ] [
  30         [ swap specializer-predicate append ] { } assoc>map
  31         [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
  32     ] if-empty ;
  33
  34 : specializer-cases ( quot specializer -- alist )
  35     dup [ array? ] all? [ 1array ] unless [
  36         [ nip make-specializer ]
  37         [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
  38     ] with { } map>assoc ;
  39
  40 : specialize-quot ( quot word specializer -- quot' )
  41     [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
  42
  43 ! compiler.tree.propagation.inlining sets this to f
  44 SYMBOL: specialize-method?
  45
  46 t specialize-method? set-global
  47
  48 : method-declaration ( method -- quot )
  49     [ "method-generic" word-prop dispatch# object <array> ]
  50     [ "method-class" word-prop ]
  51     bi prefix [ declare ] curry [ ] like ;
  52
  53 : specialize-method ( quot method -- quot' )
  54     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
  55     [ dup "method-generic" word-prop specializer ] bi
  56     [ specialize-quot ] [ drop ] if* ;
  57
  58 : standard-method? ( method -- ? )
  59     dup method-body? [
  60         "method-generic" word-prop standard-generic?
  61     ] [ drop f ] if ;
  62
  63 : (specialized-def) ( word -- quot )
  64     [ def>> ] keep
  65     dup generic? [ drop ] [
  66         [ dup standard-method? [ specialize-method ] [ drop ] if ]
  67         [ dup specializer [ specialize-quot ] [ drop ] if* ]
  68         bi
  69     ] if ;
  70
  71 ERROR: type-mismatch-error word expected-types ;
  72
  73 : typed-stack-effect? ( effect -- ? )
  74     [ object = ] all? not ;
  75
  76 : type-mismatch-quot ( word types -- quot )
  77     [ type-mismatch-error ] 2curry ;
  78
  79 : make-coercer ( types -- quot )
  80     [ "coercer" word-prop [ ] or ]
  81     [ swap \ dip [ ] 2sequence prepend ]
  82     map-reduce ;
  83
  84 : typed-inputs ( quot word -- quot' )
  85     dup stack-effect effect-in-types {
  86         [ 2nip make-coercer ]
  87         [ 2nip make-specializer ]
  88         [ nip swap '[ _ declare @ ] ]
  89         [ [ drop ] 2dip type-mismatch-quot ]
  90     } 3cleave '[ @ @ _ _ if ] ;
  91
  92 : specialized-def ( word -- quot )
  93     [ (specialized-def) ] keep
  94     dup stack-effect effect-in-types typed-stack-effect?
  95     [ typed-inputs ] [ drop ] if ;
  96
  97 : specialized-length ( specializer -- n )
  98     dup [ array? ] all? [ first ] when length ;
  99
 100 SYNTAX: HINTS:
 101     scan-object dup wrapper? [ wrapped>> ] when
 102     [ changed-definition ]
 103     [ subwords [ changed-definition ] each ]
 104     [ parse-definition { } like "specializer" set-word-prop ] tri ;
 105
 106 ! Default specializers
 107 { first first2 first3 first4 }
 108 [ { array } "specializer" set-word-prop ] each
 109
 110 { last pop* pop } [
 111     { vector } "specializer" set-word-prop
 112 ] each
 113
 114 \ push { { vector } { sbuf } } "specializer" set-word-prop
 115
 116 \ last { { vector } } "specializer" set-word-prop
 117
 118 \ set-last { { object vector } } "specializer" set-word-prop
 119
 120 \ push-all
 121 { { string sbuf } { array vector } { byte-array byte-vector } }
 122 "specializer" set-word-prop
 123
 124 \ append
 125 { { string string } { array array } }
 126 "specializer" set-word-prop
 127
 128 \ subseq
 129 { { fixnum fixnum string } { fixnum fixnum array } }
 130 "specializer" set-word-prop
 131
 132 \ reverse-here
 133 { { string } { array } }
 134 "specializer" set-word-prop
 135
 136 \ mismatch
 137 { string string }
 138 "specializer" set-word-prop
 139
 140 \ >string { sbuf } "specializer" set-word-prop
 141
 142 \ >array { { vector } } "specializer" set-word-prop
 143
 144 \ >vector { { array } { vector } } "specializer" set-word-prop
 145
 146 \ >sbuf { string } "specializer" set-word-prop
 147
 148 \ split, { string string } "specializer" set-word-prop
 149
 150 \ memq? { array } "specializer" set-word-prop
 151
 152 \ member? { array } "specializer" set-word-prop
 153
 154 \ assoc-stack { vector } "specializer" set-word-prop
 155
 156 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
 157
 158 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
 159
 160 \ base> { string fixnum } "specializer" set-word-prop
 161
 162 M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
 163
 164 M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop