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     { dupd  ( x y     -- x x y           ) }
  75     { swapd ( x y z   -- y x z           ) }
  76     { nip   ( x y     -- y               ) }
  77     { 2nip  ( x y z   -- z               ) }
  78     { over  ( x y     -- x y x           ) }
  79     { pick  ( x y z   -- x y z x         ) }
  80     { swap  ( x y     -- y x             ) }
  81 } [ "shuffle" set-word-prop ] assoc-each
  82
  83 : check-declaration ( declaration -- declaration )
  84     dup { [ array? ] [ [ classoid? ] all? ] } 1&&
  85     [ bad-declaration-error ] unless ;
  86
  87 : infer-declare ( -- )
  88     pop-literal check-declaration
  89     [ length ensure-d ] keep zip
  90     #declare, ;
  91
  92 \ declare [ infer-declare ] "special" set-word-prop
  93
  94 ! Call
  95 GENERIC: infer-call* ( value known -- )
  96
  97 : (infer-call) ( value -- ) dup known infer-call* ;
  98
  99 : infer-call ( -- ) pop-d (infer-call) ;
 100
 101 \ call [ infer-call ] "special" set-word-prop
 102
 103 \ (call) [ infer-call ] "special" set-word-prop
 104
 105 M: literal-tuple infer-call*
 106     [ 1array #drop, ] [ infer-literal-quot ] bi* ;
 107
 108 M: curried-effect infer-call*
 109     swap push-d
 110     [ uncurry ] infer-quot-here
 111     [ quot>> known pop-d [ set-known ] keep ]
 112     [ obj>> known pop-d [ set-known ] keep ] bi
 113     push-d (infer-call) ;
 114
 115 M: composed-effect infer-call*
 116     swap push-d
 117     [ uncompose ] infer-quot-here
 118     [ quot2>> known pop-d [ set-known ] keep ]
 119     [ quot1>> known pop-d [ set-known ] keep ] bi
 120     push-d push-d
 121     1 infer->r infer-call
 122     terminated? get [ 1 infer-r> infer-call ] unless ;
 123
 124 M: declared-effect infer-call*
 125     [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
 126
 127 M: input-parameter infer-call* \ call unknown-macro-input ;
 128
 129 M: object infer-call* \ call bad-macro-input ;
 130
 131 :: infer-ndip ( word n -- )
 132     literals get [
 133         word def>> infer-quot-here
 134     ] [
 135         pop n [ infer->r infer-quot-here ] [ infer-r> ] bi
 136     ] if-empty ;
 137
 138 : infer-dip ( -- ) \ dip 1 infer-ndip ;
 139
 140 \ dip [ infer-dip ] "special" set-word-prop
 141
 142 : infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
 143
 144 \ 2dip [ infer-2dip ] "special" set-word-prop
 145
 146 : infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
 147
 148 \ 3dip [ infer-3dip ] "special" set-word-prop
 149
 150 :: infer-builder ( quot word -- )
 151     2 consume-d dup first2 quot call make-known
 152     [ push-d ] [ 1array ] bi word #call, ; inline
 153
 154 : infer-curry ( -- ) [ <curried-effect> ] \ curry infer-builder ;
 155
 156 \ curry [ infer-curry ] "special" set-word-prop
 157
 158 : infer-compose ( -- ) [ <composed-effect> ] \ compose infer-builder ;
 159
 160 \ compose [ infer-compose ] "special" set-word-prop
 161
 162 : infer-execute ( -- )
 163     pop-literal
 164     dup word? [
 165         apply-object
 166     ] [
 167         \ execute time-bomb
 168     ] if ;
 169
 170 \ execute [ infer-execute ] "special" set-word-prop
 171
 172 \ (execute) [ infer-execute ] "special" set-word-prop
 173
 174 : infer-<tuple-boa> ( -- )
 175     \ <tuple-boa>
 176     peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
 177     apply-word/effect ;
 178
 179 \ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
 180
 181 : infer-effect-unsafe ( word -- )
 182     pop-literal
 183     add-effect-input
 184     apply-word/effect ;
 185
 186 : infer-execute-effect-unsafe ( -- )
 187     \ (execute) infer-effect-unsafe ;
 188
 189 \ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
 190
 191 : infer-call-effect-unsafe ( -- )
 192     \ call infer-effect-unsafe ;
 193
 194 \ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
 195
 196 : infer-load-locals ( -- )
 197     pop-literal
 198     consume-d dup copy-values dup output-r
 199     [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 200
 201 \ load-locals [ infer-load-locals ] "special" set-word-prop
 202
 203 : infer-load-local ( -- )
 204     1 infer->r ;
 205
 206 \ load-local [ infer-load-local ] "special" set-word-prop
 207
 208 :: infer-get-local ( -- )
 209     pop-literal 1 swap - :> n
 210     n consume-r :> in-r
 211     in-r first copy-value 1array :> out-d
 212     in-r copy-values :> out-r
 213
 214     out-d output-d
 215     out-r output-r
 216     f out-d in-r out-r
 217     out-r in-r zip out-d first in-r first 2array suffix
 218     #shuffle, ;
 219
 220 \ get-local [ infer-get-local ] "special" set-word-prop
 221
 222 : infer-drop-locals ( -- )
 223     f f pop-literal consume-r f f #shuffle, ;
 224
 225 \ drop-locals [ infer-drop-locals ] "special" set-word-prop
 226
 227 : infer-call-effect ( word -- )
 228     1 ensure-d first literal value>>
 229     add-effect-input add-effect-input
 230     apply-word/effect ;
 231
 232 { call-effect execute-effect } [
 233     dup t "no-compile" set-word-prop
 234     dup '[ _ infer-call-effect ] "special" set-word-prop
 235 ] each
 236
 237 \ if [ infer-if ] "special" set-word-prop
 238 \ dispatch [ infer-dispatch ] "special" set-word-prop
 239
 240 \ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
 241 \ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
 242 \ alien-assembly [ infer-alien-assembly ] "special" set-word-prop
 243 \ alien-callback [ infer-alien-callback ] "special" set-word-prop
 244
 245 {
 246     c-to-factor
 247     do-primitive
 248     mega-cache-lookup
 249     mega-cache-miss
 250     inline-cache-miss
 251     inline-cache-miss-tail
 252     lazy-jit-compile
 253     set-callstack
 254     set-datastack
 255     set-retainstack
 256     unwind-native-frames
 257 } [ dup '[ _ do-not-compile ] "special" set-word-prop ] each
 258
 259 {
 260     declare call (call) dip 2dip 3dip curry compose
 261     execute (execute) call-effect-unsafe execute-effect-unsafe
 262     if dispatch <tuple-boa> do-primitive
 263     load-local load-locals get-local drop-locals
 264     alien-invoke alien-indirect alien-callback alien-assembly
 265 } [ t "no-compile" set-word-prop ] each
 266
 267 ! Exceptions to the above
 268 \ curry f "no-compile" set-word-prop
 269 \ compose f "no-compile" set-word-prop
 270
 271 ! More words not to compile
 272 \ clear t "no-compile" set-word-prop