: default-cli-args
#! Some flags are *on* by default, unless user specifies
#! -no-<flag> CLI switch
- t "user-init" set
- t "interactive" set
- t "smart-terminal" set
- t "verbose-compile" set
- t "compile" set ;
+ "user-init" on
+ "interactive" on
+ "smart-terminal" on
+ "verbose-compile" on
+ "compile" on
+ os "win32" = [ "graphical" on ] when ;
: cli-args ( -- args ) 10 getenv ;
USE: unparser
USE: vectors
USE: words
+USE: test
: supported-cpu? ( -- ? )
cpu "unknown" = not ;
: compile-all ( -- )
#! Compile all words.
supported-cpu? [
- [ try-compile ] each-word
+ [ [ try-compile ] each-word ] time
] [
"Unsupported CPU" print
] ifte ;
USE: hashtables
USE: prettyprint
+! If this symbol is on, partial evalution of conditionals is
+! disabled.
+SYMBOL: inferring-base-case
+
: vector-length< ( vec1 vec2 -- ? )
swap vector-length swap vector-length < ;
d-in [ deep-clone-vector ] change
dataflow-graph off ;
-: infer-branch ( value save-effect -- namespace )
+: infer-branch ( value -- namespace )
<namespace> [
- save-effect set
uncons [ unswons [ \ value-class set ] bind ] when*
dup value-recursion recursive-state set
copy-inference
#! Return effect namespace if inference didn't fail.
[
[ dual-branch dual-recursive-state set ] keep
- f infer-branch
+ infer-branch
] [
[ 2drop f ] when
] catch ;
#! Either the word is not recursive, or it is recursive
#! and the base case throws an error.
[
+ inferring-base-case on
+
[ terminator-quot? not ] subset dup length 1 > [
infer-base-cases unify-effects
effect dual-recursive-state get set-base
] [
drop
] ifte
+
+ inferring-base-case off
] with-scope ;
: (infer-branches) ( branchlist -- list )
#! is a pair [ value | class ] indicating a type propagation
#! for the given branch.
dup infer-base-case [
- dup t infer-branch swap terminator-quot? [
+ dup infer-branch swap terminator-quot? [
[ meta-d off meta-r off d-in off ] extend
] when
] map ;
#! parameter is a vector.
(infer-branches) dup unify-effects unify-dataflow ;
+: static-branch? ( value -- )
+ literal? inferring-base-case get not and ;
+
: static-ifte ( true false -- )
#! If the branch taken is statically known, just infer
#! along that branch.
- pop-d literal-value [ drop ] [ nip ] ifte
- literal-value infer-quot ;
+ dataflow-drop, pop-d literal-value [ drop ] [ nip ] ifte
+ gensym [
+ dup value-recursion recursive-state set
+ literal-value infer-quot
+ ] (with-block) ;
: dynamic-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and
[ object general-list general-list ] ensure-d
dataflow-drop, pop-d
dataflow-drop, pop-d swap
-! peek-d literal? [
-! static-ifte
-! ] [
- dynamic-ifte ;
-! ] ifte ;
+ peek-d static-branch? [
+ static-ifte
+ ] [
+ dynamic-ifte
+ ] ifte ;
\ ifte [ infer-ifte ] "infer" set-word-property
! makes a local jump to this label.
SYMBOL: recursive-label
-! When inferring stack effects of mutually recursive words, we
-! don't want to save the fact that one word does not have a
-! stack effect before the base case of its mutual pair is
-! inferred.
-SYMBOL: save-effect
-
! A value has the following slots:
GENERIC: literal-value ( value -- obj )
GENERIC: value= ( literal value -- ? )
init-interpreter
0 <vector> d-in set
recursive-state set
- dataflow-graph off
- save-effect on ;
+ dataflow-graph off ;
DEFER: apply-word
[ swap <chained-error> rethrow ] when*
] catch ;
-: (infer-compound) ( word -- effect )
+: infer-compound ( word -- effect )
#! Infer a word's stack effect in a separate inferencer
#! instance.
[
recursive-state get init-inference
- dup inline-compound
+ dup dup inline-compound
[ "infer-effect" set-word-property ] keep
- ] with-scope ;
-
-: infer-compound ( word -- )
- #! Infer the stack effect of a compound word in a separate
- #! inferencer instance, caching the result.
- [
- dup (infer-compound) consume/produce
- ] [
- [
- swap save-effect get [
- t "no-effect" set-word-property
- ] [
- drop
- ] ifte rethrow
- ] when*
- ] catch ;
+ ] with-scope consume/produce ;
GENERIC: (apply-word)
[ [ call ] infer old-effect ] unit-test-fails
[ [ 2 | 4 ] ] [ [ 2dup ] infer old-effect ] unit-test
-[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test
[ [ 2 | 0 ] ] [ [ vector-push ] infer old-effect ] unit-test
[ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test
[ [ bad-recursion-2 ] infer old-effect ] unit-test-fails
+! Not sure how to fix this one
+
+! : funny-recursion
+! dup [ funny-recursion 1 ] [ 2 ] ifte drop ;
+!
+! [ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test
+
! Simple combinators
[ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test
2drop f
] ifte ;
+[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
+
! This form should not have a stack effect
: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
[ [ bad-bin ] infer old-effect ] unit-test-fails
[ [ 0 | 1 ] ] [ [ sym-test ] infer old-effect ] unit-test
-[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test
-[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
+[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test
[ [ 2 | 1 ] ] [ [ 2list ] infer old-effect ] unit-test
[ [ 3 | 1 ] ] [ [ 3list ] infer old-effect ] unit-test
[ [ 2 | 1 ] ] [ [ append ] infer old-effect ] unit-test