Slight speedup

slava 2006-08-18 05:50:34 +00:00
parent b4683b1985
commit 77561573e0
5 changed files with 20 additions and 8 deletions

View File

@ -4,7 +4,6 @@
- document inference errors
- update docs for declared effects
- better doc for accumulate, link from tree
- bootstrap speedup with compiling recursives
- RT_WORD should refer to XTs not word objects.
- better listener multi-line expression handling
- history doesn't work in a good way if you ^K the input

View File

@ -7,6 +7,7 @@ words ;
: word-dataflow ( word -- dataflow )
[
dup ?no-effect
dup dup add-recursive-state
dup specialized-def (dataflow)
swap current-effect check-effect

View File

@ -98,6 +98,11 @@ M: quotation infer-quot
inference-error
] unless ;
: undo-infer ( -- )
recorded get
[ "infer" word-prop not ] subset
[ f "infer-effect" set-word-prop ] each ;
: with-infer ( quot -- )
[
[
@ -107,7 +112,7 @@ M: quotation infer-quot
call
check-return
] [
recorded get [ f "infer-effect" set-word-prop ] each
undo-infer
rethrow
] recover
] with-scope ;

View File

@ -118,10 +118,14 @@ TUPLE: effect-error word effect ;
: effect-error ( word effect -- * ) <effect-error> throw ;
: check-effect ( word effect -- )
over recorded get push
dup pick "declared-effect" word-prop dup
[ effect<= [ effect-error ] unless ] [ 2drop ] if
"infer-effect" set-word-prop ;
over "infer" word-prop [
2drop
] [
over recorded get push
dup pick "declared-effect" word-prop dup
[ effect<= [ effect-error ] unless ] [ 2drop ] if
"infer-effect" set-word-prop
] if ;
M: compound apply-word
#! Infer a compound word's stack effect.
@ -131,8 +135,11 @@ M: compound apply-word
swap t "no-effect" set-word-prop rethrow
] recover ;
: ?no-effect ( word -- )
dup "no-effect" word-prop [ no-effect ] [ drop ] if ;
: apply-default ( word -- )
dup "no-effect" word-prop [ no-effect ] when
dup ?no-effect
dup "infer-effect" word-prop [
over "infer" word-prop [
swap effect-in length ensure-values call drop

View File

@ -31,7 +31,7 @@ M: number equal? number= ;
: >polar ( z -- abs arg )
dup abs swap >rect swap fatan2 ; inline
: cis ( arg --- z ) dup fcos swap fsin rect> ; inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline