{
[ inline? ]
[ macro? ]
- [ "transform-quot" word-prop ]
[ "no-compile" word-prop ]
[ "special" word-prop ]
} 1||
f compiler-impl set-global ;
: recompile-all ( -- )
- forget-errors all-words compile ;
+ all-words compile ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators compiler.tree
+assocs words arrays vectors hints combinators continuations
+effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
with-infer nip ; inline
: build-tree ( quot -- nodes )
- #! Not safe to call from inference transforms.
[ f initial-recursive-state infer-quot ] with-tree-builder ;
: build-tree-with ( in-stack quot -- nodes out-stack )
- #! Not safe to call from inference transforms.
[
- [ >vector \ meta-d set ]
- [ f initial-recursive-state infer-quot ] bi*
- ] with-tree-builder
- unclip-last in-d>> ;
+ [
+ [ >vector \ meta-d set ]
+ [ f initial-recursive-state infer-quot ] bi*
+ ] with-tree-builder
+ unclip-last in-d>>
+ ] [ "OOPS" USE: io print flush 3drop f f ] recover ;
-: build-sub-tree ( #call quot -- nodes )
+: build-sub-tree ( #call quot -- nodes/f )
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
- over ends-with-terminate?
- [ drop swap [ f swap #push ] map append ]
- [ rot #copy suffix ]
- if ;
+ {
+ { [ over not ] [ 3drop f ] }
+ { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] }
+ [ rot #copy suffix ]
+ } cond ;
+
+: check-no-compile ( word -- )
+ dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
: (build-tree-from-word) ( word -- )
dup initial-recursive-state recursive-state set
[ 1quotation ] [ specialized-def ] if
infer-quot-here ;
-: check-cannot-infer ( word -- )
- dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+: check-effect ( word effect -- )
+ over required-stack-effect 2dup effect<=
+ [ 3drop ] [ effect-error ] if ;
-TUPLE: do-not-compile word ;
-
-: check-no-compile ( word -- )
- dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
+: finish-word ( word -- )
+ current-effect check-effect ;
: build-tree-from-word ( word -- nodes )
[
- [
- {
- [ check-cannot-infer ]
- [ check-no-compile ]
- [ (build-tree-from-word) ]
- [ finish-word ]
- } cleave
- ] maybe-cannot-infer
+ [ check-no-compile ]
+ [ (build-tree-from-word) ]
+ [ finish-word ]
+ tri
] with-tree-builder ;
: contains-breakpoints? ( word -- ? )
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart hints
+locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
SYMBOL: inlining-count
! Splicing nodes
-GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
+GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f )
M: word splicing-nodes
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
M: callable splicing-nodes
- build-sub-tree analyze-recursive normalize ;
+ build-sub-tree dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
+: undo-inlining ( #call -- ? )
+ f >>method f >>body f >>class drop f ;
+
+: propagate-body ( #call -- ? )
+ body>> (propagate) t ;
+
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
- over method>> over = [ drop ] [
- 2dup splicing-nodes
- [ >>method ] [ >>body ] bi*
+ over method>> over = [ drop propagate-body ] [
+ 2dup splicing-nodes dup [
+ [ >>method ] [ >>body ] bi* propagate-body
+ ] [ 2drop undo-inlining ] if
] if
- body>> (propagate) t
- ] [ 2drop f >>method f >>body f >>class drop f ] if ;
+ ] [ 2drop undo-inlining ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
[ history [ swap suffix ] change ]
bi ;
-: inline-word-def ( #call word quot -- ? )
- over history get memq? [ 3drop f ] [
- [
- [ remember-inlining ] dip
- [ drop ] [ splicing-nodes ] 2bi
- [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
- ] with-scope node-count +@
- t
+:: inline-word-def ( #call word quot -- ? )
+ word history get memq? [ f ] [
+ #call quot splicing-nodes [
+ [
+ word remember-inlining
+ [ ] [ count-nodes ] [ (propagate) ] tri
+ ] with-scope
+ [ #call (>>body) ] [ node-count +@ ] bi* t
+ ] [ f ] if*
] if ;
: inline-word ( #call word -- ? )
SYNTAX: HINTS:
scan-object
- [ redefined ]
+ [ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
! Default specializers
drop ;
[ "drop ;" ] [
- \ blah f "inferred-effect" set-word-prop
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic io io.streams.string kernel math
namespaces parser sequences strings vectors words quotations
effects classes continuations assocs combinators
compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints stack-checker.state
+generic.standard.engines.tuple hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.backend
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-: undo-infer ( -- )
- recorded get [ f "inferred-effect" set-word-prop ] each ;
-
: (consume/produce) ( effect -- inputs outputs )
[ in>> length consume-d ] [ out>> length produce-d ] bi ;
[ terminated?>> [ terminate ] when ]
bi ; inline
-: infer-word-def ( word -- )
- [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
-
: end-infer ( -- )
meta-d clone #return, ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ missing-effect ] ?if ;
-: check-effect ( word effect -- )
- over required-stack-effect 2dup effect<=
- [ 3drop ] [ effect-error ] if ;
-
-: finish-word ( word -- )
- [ current-effect check-effect ]
- [ recorded get push ]
- [ t "inferred-effect" set-word-prop ]
- tri ;
-
-: cannot-infer-effect ( word -- * )
- "cannot-infer" word-prop rethrow ;
-
-: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
-
-: infer-word ( word -- effect )
- [
- [
- init-inference
- init-known-values
- stack-visitor off
- dependencies off
- generic-dependencies off
- [ infer-word-def end-infer ]
- [ finish-word ]
- [ stack-effect ]
- tri
- ] with-scope
- ] maybe-cannot-infer ;
-
: apply-word/effect ( word effect -- )
swap '[ _ #call, ] consume/produce ;
-: call-recursive-word ( word -- )
- dup required-stack-effect apply-word/effect ;
-
-: cached-infer ( word -- )
- dup stack-effect apply-word/effect ;
+: infer-word ( word -- )
+ {
+ { [ dup macro? ] [ do-not-compile ] }
+ { [ dup "no-compile" word-prop ] [ do-not-compile ] }
+ [ dup required-stack-effect apply-word/effect ]
+ } cond ;
: with-infer ( quot -- effect visitor )
[
- [
- V{ } clone recorded set
- init-inference
- init-known-values
- stack-visitor off
- call
- end-infer
- current-effect
- stack-visitor get
- ] [ ] [ undo-infer ] cleanup
+ init-inference
+ init-known-values
+ stack-visitor off
+ call
+ end-infer
+ current-effect
+ stack-visitor get
] with-scope ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms ;
+stack-checker stack-checker.transforms words ;
IN: stack-checker.call-effect
! call( and execute( have complex expansions.
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
+\ call-effect-slow t "no-compile" set-word-prop
+
: call-effect-fast ( quot effect inline-cache -- )
2over call-effect-unsafe?
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
]
] 0 define-transform
+\ call-effect t "no-compile" set-word-prop
+
: execute-effect-slow ( word effect -- )
[ '[ _ execute ] ] dip call-effect-slow ; inline
inline-cache new '[ _ _ execute-effect-ic ] ;
\ execute-effect [ execute-effect>quot ] 1 define-transform
+
+\ execute-effect t "no-compile" set-word-prop
\ No newline at end of file
: inference-warning ( ... class -- * )
+compiler-warning+ (inference-error) ; inline
+TUPLE: do-not-compile word ;
+
+: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
+
TUPLE: literal-expected what ;
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
} [ t "special" set-word-prop ] each
M\ quotation call t "no-compile" set-word-prop
+M\ curry call t "no-compile" set-word-prop
+M\ compose call t "no-compile" set-word-prop
M\ word execute t "no-compile" set-word-prop
\ clear t "no-compile" set-word-prop
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
- { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup local-word? ] [ infer-local-word ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
+ [ infer-word ]
} cond ;
: define-primitive ( word inputs outputs -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
-TUPLE: recursive-state word words quotations inline-words ;
-
-: prepare-recursive-state ( word rstate -- rstate )
- swap >>word
- f >>quotations
- f >>inline-words ; inline
+TUPLE: recursive-state word quotations inline-words ;
: initial-recursive-state ( word -- state )
recursive-state new
- f >>words
- prepare-recursive-state ; inline
+ swap >>word
+ f >>quotations
+ f >>inline-words ; inline
f initial-recursive-state recursive-state set-global
-: add-recursive-state ( word -- rstate )
- recursive-state get clone
- [ word>> dup ] keep [ store ] change-words
- prepare-recursive-state ;
-
-: add-local-quotation ( recursive-state quot -- rstate )
+: add-local-quotation ( rstate quot -- rstate )
swap clone [ dupd store ] change-quotations ;
: add-inline-word ( word label -- rstate )
swap recursive-state get clone
[ store ] change-inline-words ;
-: recursive-word? ( word -- ? )
- recursive-state get 2dup word>> eq?
- [ 2drop t ] [ words>> lookup ] if ;
-
: inline-recursive-label ( word -- label/f )
recursive-state get inline-words>> lookup ;
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
-
HELP: infer
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words
-
-HELP: forget-errors
-{ $description "Removes markers indicating which words do not have stack effects."
-$nl
-"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
[ forget-test ] must-infer
+
+[ [ cond ] infer ] must-fail
+[ [ bi ] infer ] must-fail
+[ at ] must-infer
\ No newline at end of file
#! Safe to call from inference transforms.
infer effect>string print ;
-: forget-errors ( -- )
- all-words [
- dup subwords [ f "cannot-infer" set-word-prop ] each
- f "cannot-infer" set-word-prop
- ] each ;
-
-: forget-effects ( -- )
- forget-errors
- all-words [
- dup subwords [ f "inferred-effect" set-word-prop ] each
- f "inferred-effect" set-word-prop
- ] each ;
-
"stack-checker.call-effect" require
\ No newline at end of file
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
-
-! Words we've inferred the stack effect of, for rollback
-SYMBOL: recorded
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
-: give-up-transform ( word -- )
- {
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
- } cond ;
-
: call-transformer ( word stack quot -- newquot )
'[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
[ transform-expansion-error ]
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
- ] [ word give-up-transform ] if* ;
+ ] [ word infer-word ] if* ;
: literals? ( values -- ? ) [ literal-value? ] all? ;
[ first literal recursion>> ] tri
] if
((apply-transform))
- ] [ 2drop give-up-transform ] if ;
+ ] [ 2drop infer-word ] if ;
: apply-transform ( word -- )
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
! Combinators
\ cond [ cond>quot ] 1 define-transform
+\ cond t "no-compile" set-word-prop
+
\ case [
[
[ no-case ]
] if-empty
] 1 define-transform
+\ case t "no-compile" set-word-prop
+
\ cleave [ cleave>quot ] 1 define-transform
+\ cleave t "no-compile" set-word-prop
+
\ 2cleave [ 2cleave>quot ] 1 define-transform
+\ 2cleave t "no-compile" set-word-prop
+
\ 3cleave [ 3cleave>quot ] 1 define-transform
+\ 3cleave t "no-compile" set-word-prop
+
\ spread [ spread>quot ] 1 define-transform
+\ spread t "no-compile" set-word-prop
+
\ (call-next-method) [
[
[ "method-class" word-prop ]
] bi
] 1 define-transform
+\ (call-next-method) t "no-compile" set-word-prop
+
! Constructors
\ boa [
dup tuple-class? [
] [ drop f ] if
] 1 define-transform
+\ boa t "no-compile" set-word-prop
+M\ tuple-class boa t "no-compile" set-word-prop
+
\ new [
dup tuple-class? [
dup inlined-dependency depends-on
{
"alias"
"boa-check"
- "cannot-infer"
"coercer"
"combination"
"compiled-status"
"identities"
"if-intrinsics"
"infer"
- "inferred-effect"
"inline"
"inlined-block"
"input-classes"
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
[ reset-class ]
[ ?define-symbol ]
- [ redefined ]
+ [ changed-definition ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
2drop
[
[ update-tuples-after ]
- [ redefined ]
+ [ changed-definition ]
bi
] each-subclass
]
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
- { { $snippet "\"infer\"" } { $link "macros" } }
-
- { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
-
{ { $snippet "\"specializer\"" } { $link "hints" } }
{ { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
M: word subwords drop f ;
-<PRIVATE
-
-SYMBOL: visited
-
-CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
-
-: relevant-callers ( word -- seq )
- crossref get at keys
- [ word? ] filter
- [
- [ reset-on-redefine [ word-prop ] with any? ]
- [ inline? ]
- bi or
- ] filter ;
-
-: (redefined) ( word -- )
- dup visited get key? [ drop ] [
- [ reset-on-redefine reset-props ]
- [ visited get conjoin ]
- [
- [ relevant-callers [ (redefined) ] each ]
- [ subwords [ (redefined) ] each ]
- bi
- ] tri
- ] if ;
-
-PRIVATE>
-
-: redefined ( word -- )
- [ H{ } clone visited [ (redefined) ] with-variable ]
- [ changed-definition ]
- bi ;
-
: define ( word def -- )
[ ] like
over unxref
- over redefined
+ over changed-definition
>>def
dup crossref? [ dup xref ] when drop ;
swap
[ drop changed-effect ]
[ "declared-effect" set-word-prop ]
- [ drop dup primitive? [ drop ] [ redefined ] if ]
+ [ drop dup primitive? [ drop ] [ changed-definition ] if ]
2tri
] if ;
projects / factor.git / commitdiff