basis/stack-checker/known-words/known-words.factor

   1 ! Copyright (C) 2004, 2011 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry accessors alien alien.accessors alien.private arrays
   4 byte-arrays classes continuations.private effects generic
   5 hashtables hashtables.private io io.backend io.files
   6 io.files.private io.streams.c kernel kernel.private math
   7 math.private math.parser.private memory memory.private
   8 namespaces namespaces.private parser quotations
   9 quotations.private sbufs sbufs.private sequences
  10 sequences.private slots.private strings strings.private system
  11 threads.private classes.tuple classes.tuple.private vectors
  12 vectors.private words words.private definitions assocs summary
  13 compiler.units system.private combinators tools.memory.private
  14 combinators.short-circuit locals locals.backend locals.types
  15 combinators.private stack-checker.values generic.single
  16 generic.single.private alien.libraries tools.dispatch.private
  17 macros tools.profiler.sampling.private classes.algebra
  18 stack-checker.alien
  19 stack-checker.state
  20 stack-checker.errors
  21 stack-checker.visitor
  22 stack-checker.backend
  23 stack-checker.branches
  24 stack-checker.transforms
  25 stack-checker.dependencies
  26 stack-checker.recursive-state
  27 stack-checker.row-polymorphism ;
  28 QUALIFIED-WITH: generic.single.private gsp
  29 IN: stack-checker.known-words
  30
  31 : infer-special ( word -- )
  32     [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
  33
  34 : infer-shuffle ( shuffle -- )
  35     [ in>> length consume-d ] keep ! inputs shuffle
  36     [ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
  37     [ nip f f ] [ swap zip ] 2bi ! in-d out-d in-r out-r mapping
  38     #shuffle, ;
  39
  40 : infer-shuffle-word ( word -- )
  41     "shuffle" word-prop infer-shuffle ;
  42
  43 : infer-local-reader ( word -- )
  44     ( -- value ) apply-word/effect ;
  45
  46 : infer-local-writer ( word -- )
  47     ( value -- ) apply-word/effect ;
  48
  49 : non-inline-word ( word -- )
  50     dup +effect+ depends-on
  51     {
  52         { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
  53         { [ dup "special" word-prop ] [ infer-special ] }
  54         { [ dup "transform-quot" word-prop ] [ apply-transform ] }
  55         { [ dup macro? ] [ apply-macro ] }
  56         { [ dup local? ] [ infer-local-reader ] }
  57         { [ dup local-reader? ] [ infer-local-reader ] }
  58         { [ dup local-writer? ] [ infer-local-writer ] }
  59         { [ dup "no-compile" word-prop ] [ do-not-compile ] }
  60         [ dup required-stack-effect apply-word/effect ]
  61     } cond ;
  62
  63 {
  64     { drop  ( x         --                 ) }
  65     { 2drop ( x y       --                 ) }
  66     { 3drop ( x y z     --                 ) }
  67     { 4drop ( w x y z   --                 ) }
  68     { dup   ( x         -- x x             ) }
  69     { 2dup  ( x y       -- x y x y         ) }
  70     { 3dup  ( x y z     -- x y z x y z     ) }
  71     { 4dup  ( w x y z   -- w x y z w x y z ) }
  72     { rot   ( x y z     -- y z x           ) }
  73     { -rot  ( x y z     -- z x y           ) }
  74     { roll  ( w x y z   -- x y z w         ) }
  75     { -roll ( w x y z   -- z w x y         ) }
  76     { reach ( w x y z   -- w x y z w       ) }
  77     { dupd  ( x y       -- x x y           ) }
  78     { swapd ( x y z     -- y x z           ) }
  79     { nip   ( x y       -- y               ) }
  80     { 2nip  ( x y z     -- z               ) }
  81     { 3nip  ( w x y z   -- z               ) }
  82     { 4nip  ( v w x y z -- z               ) }
  83     { nipd  ( x y z     -- y z             ) }
  84     { 2nipd ( w x y z   -- y z             ) }
  85     { 3nipd ( v w x y z -- y z             ) }
  86     { over  ( x y       -- x y x           ) }
  87     { overd ( x y z     -- x y x z         ) }
  88     { pick  ( x y z     -- x y z x         ) }
  89     { pickd ( w x y z   -- w x y w z       ) }
  90     { swap  ( x y       -- y x             ) }
  91     { tuck  ( x y       -- y x y           ) }
  92 } [ "shuffle" set-word-prop ] assoc-each
  93
  94 : check-declaration ( declaration -- declaration )
  95     dup { [ array? ] [ [ classoid? ] all? ] } 1&&
  96     [ bad-declaration-error ] unless ;
  97
  98 : infer-declare ( -- )
  99     pop-literal check-declaration
 100     [ length ensure-d ] keep zip
 101     #declare, ;
 102
 103 \ declare [ infer-declare ] "special" set-word-prop
 104
 105 ! Call
 106 GENERIC: infer-call* ( value known -- )
 107
 108 : (infer-call) ( value -- ) dup known infer-call* ;
 109
 110 : infer-call ( -- ) pop-d (infer-call) ;
 111
 112 \ call [ infer-call ] "special" set-word-prop
 113
 114 \ (call) [ infer-call ] "special" set-word-prop
 115
 116 M: literal-tuple infer-call*
 117     [ 1array #drop, ] [ infer-literal-quot ] bi* ;
 118
 119 M: curried-effect infer-call*
 120     swap push-d
 121     [ uncurry ] infer-quot-here
 122     [ quot>> known pop-d [ set-known ] keep ]
 123     [ obj>> known pop-d [ set-known ] keep ] bi
 124     push-d (infer-call) ;
 125
 126 M: composed-effect infer-call*
 127     swap push-d
 128     [ uncompose ] infer-quot-here
 129     [ quot2>> known pop-d [ set-known ] keep ]
 130     [ quot1>> known pop-d [ set-known ] keep ] bi
 131     push-d push-d
 132     1 infer->r infer-call
 133     terminated? get [ 1 infer-r> infer-call ] unless ;
 134
 135 M: declared-effect infer-call*
 136     [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
 137
 138 M: input-parameter infer-call* \ call unknown-macro-input ;
 139
 140 M: object infer-call* \ call bad-macro-input ;
 141
 142 :: infer-ndip ( word n -- )
 143     literals get [
 144         word def>> infer-quot-here
 145     ] [
 146         pop n [ infer->r infer-quot-here ] [ infer-r> ] bi
 147     ] if-empty ;
 148
 149 : infer-dip ( -- ) \ dip 1 infer-ndip ;
 150
 151 \ dip [ infer-dip ] "special" set-word-prop
 152
 153 : infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
 154
 155 \ 2dip [ infer-2dip ] "special" set-word-prop
 156
 157 : infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
 158
 159 \ 3dip [ infer-3dip ] "special" set-word-prop
 160
 161 :: infer-builder ( quot word -- )
 162     2 consume-d dup first2 quot call make-known
 163     [ push-d ] [ 1array ] bi word #call, ; inline
 164
 165 : infer-curry ( -- ) [ <curried-effect> ] \ curry infer-builder ;
 166
 167 \ curry [ infer-curry ] "special" set-word-prop
 168
 169 : infer-compose ( -- ) [ <composed-effect> ] \ compose infer-builder ;
 170
 171 \ compose [ infer-compose ] "special" set-word-prop
 172
 173 : infer-execute ( -- )
 174     pop-literal
 175     dup word? [
 176         apply-object
 177     ] [
 178         \ execute time-bomb
 179     ] if ;
 180
 181 \ execute [ infer-execute ] "special" set-word-prop
 182
 183 \ (execute) [ infer-execute ] "special" set-word-prop
 184
 185 : infer-<tuple-boa> ( -- )
 186     \ <tuple-boa>
 187     peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
 188     apply-word/effect ;
 189
 190 \ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
 191
 192 : infer-effect-unsafe ( word -- )
 193     pop-literal
 194     add-effect-input
 195     apply-word/effect ;
 196
 197 : infer-execute-effect-unsafe ( -- )
 198     \ (execute) infer-effect-unsafe ;
 199
 200 \ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
 201
 202 : infer-call-effect-unsafe ( -- )
 203     \ call infer-effect-unsafe ;
 204
 205 \ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
 206
 207 : infer-load-locals ( -- )
 208     pop-literal
 209     consume-d dup copy-values dup output-r
 210     [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 211
 212 \ load-locals [ infer-load-locals ] "special" set-word-prop
 213
 214 : infer-load-local ( -- )
 215     1 infer->r ;
 216
 217 \ load-local [ infer-load-local ] "special" set-word-prop
 218
 219 :: infer-get-local ( -- )
 220     pop-literal 1 swap - :> n
 221     n consume-r :> in-r
 222     in-r first copy-value 1array :> out-d
 223     in-r copy-values :> out-r
 224
 225     out-d output-d
 226     out-r output-r
 227     f out-d in-r out-r
 228     out-r in-r zip out-d first in-r first 2array suffix
 229     #shuffle, ;
 230
 231 \ get-local [ infer-get-local ] "special" set-word-prop
 232
 233 : infer-drop-locals ( -- )
 234     f f pop-literal consume-r f f #shuffle, ;
 235
 236 \ drop-locals [ infer-drop-locals ] "special" set-word-prop
 237
 238 : infer-call-effect ( word -- )
 239     1 ensure-d first literal value>>
 240     add-effect-input add-effect-input
 241     apply-word/effect ;
 242
 243 { call-effect execute-effect } [
 244     dup t "no-compile" set-word-prop
 245     dup '[ _ infer-call-effect ] "special" set-word-prop
 246 ] each
 247
 248 \ if [ infer-if ] "special" set-word-prop
 249 \ dispatch [ infer-dispatch ] "special" set-word-prop
 250
 251 \ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
 252 \ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
 253 \ alien-assembly [ infer-alien-assembly ] "special" set-word-prop
 254 \ alien-callback [ infer-alien-callback ] "special" set-word-prop
 255
 256 {
 257     c-to-factor
 258     do-primitive
 259     mega-cache-lookup
 260     mega-cache-miss
 261     inline-cache-miss
 262     inline-cache-miss-tail
 263     lazy-jit-compile
 264     set-callstack
 265     set-datastack
 266     set-retainstack
 267     unwind-native-frames
 268 } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
 269
 270 {
 271     declare call (call) dip 2dip 3dip curry compose
 272     execute (execute) call-effect-unsafe execute-effect-unsafe
 273     if dispatch <tuple-boa> do-primitive
 274     load-local load-locals get-local drop-locals
 275     alien-invoke alien-indirect alien-callback alien-assembly
 276 } [ t "no-compile" set-word-prop ] each
 277
 278 ! Exceptions to the above
 279 \ curry f "no-compile" set-word-prop
 280 \ compose f "no-compile" set-word-prop
 281
 282 ! More words not to compile
 283 \ clear t "no-compile" set-word-prop