[error] AWT-EventQueue-0: at factor.jedit.WordPreview.actionPerformed(WordPreview.java:79)\r
[error] AWT-EventQueue-0: at javax.swing.Timer.fireActionPerformed(Timer.java:271)\r
\r
-+ inference/dataflow:\r
-\r
-- type inference\r
-\r
+ compiler:\r
\r
-- slot compilation\r
- optimize away dispatch\r
- getenv/setenv: if literal arg, compile as a load/store\r
- assembler opcodes dispatch on operand types\r
"/library/inference/branches.factor"\r
"/library/inference/words.factor"\r
"/library/inference/stack.factor"\r
+ "/library/inference/types.factor"\r
\r
"/library/compiler/assembler.factor"\r
"/library/compiler/xt.factor"\r
BUILTIN: alien 16
M: alien hashcode ( obj -- n )
- alien-address ;
+ alien-address >fixnum ;
M: alien = ( obj obj -- ? )
over alien? [
#! MOV INDIRECT <reg> TO <reg>.
HEX: 8b compile-byte 0 MOD-R/M ;
+: D[R]>R ( disp reg reg -- )
+ #! MOV INDIRECT DISPLACED <reg> TO <reg>.
+ HEX: 8b compile-byte 1 MOD-R/M compile-byte ;
+
: R>[R] ( reg reg -- )
#! MOV <reg> TO INDIRECT <reg>.
HEX: 89 compile-byte swap 0 MOD-R/M ;
#slot [
PEEK-DS
-
+ 2unlist type-tag >r cell * r> - EAX EAX D[R]>R
+ DS ECX [I]>R absolute-ds
+ EAX ECX R>[R]
] "generator" set-word-property
#call [
] catch ;
#label [ save-xt ] "generator" set-word-property
+
+: type-tag ( type -- tag )
+ #! Given a type number, return the tag number.
+ dup 6 > [ drop 3 ] when ;
SYMBOL: object
: type-union ( list list -- list )
- append prune [ > ] sort ;
-
-: type-intersection ( list list -- list )
- intersection [ > ] sort ;
+ append prune ;
: lookup-union ( typelist -- class )
- classes get hash [ object ] unless* ;
+ [ > ] sort classes get hash [ object ] unless* ;
: class-or ( class class -- class )
#! Return a class that both classes are subclasses of.
swap builtin-supertypes
type-union lookup-union ;
+: class-or-list ( list -- class )
+ #! Return a class that every class in the list is a
+ #! subclass of.
+ [
+ [ builtin-supertypes [ unique, ] each ] each
+ ] make-list lookup-union ;
+
: class-and ( class class -- class )
#! Return a class that is a subclass of both, or raise an
#! error if this is impossible.
over builtin-supertypes
over builtin-supertypes
- type-intersection dup [
+ intersection dup [
nip nip lookup-union
] [
drop [
] make-string throw
] ifte ;
+: define-promise ( class -- )
+ #! A promise is a word that has no effect during
+ #! interpretation, but instructs the compiler that the value
+ #! at the top of the stack is statically-known to be of the
+ #! given type. Promises should only be used by kernel code.
+ dup word-name "%" swap cat2 "in" get create
+ dup [ ] define-compound
+ swap "promise" set-word-property ;
+
: define-class ( class metaclass -- )
dupd "metaclass" set-word-property
+ dup define-promise
dup builtin-supertypes [ > ] sort
classes get set-hash ;
PREDICATE: compound generic ( word -- ? )
"combination" word-property ;
+
+PREDICATE: compound promise ( obj -- ? )
+ "promise" word-property ;
USE: hashtables
USE: prettyprint
-: vector-length< ( vec1 vec2 -- ? )
- swap vector-length swap vector-length < ;
-
-: unify-length ( vec1 vec2 -- vec1 )
- 2dup vector-length< [ swap ] unless [
- vector-length over vector-length -
- empty-vector [ swap vector-append ] keep
- ] keep ;
-
-: unify-classes ( value value -- class )
- #! If one of the values is f, it was added as a result of
- #! length unification so we just replace it with a computed
- #! object value.
- 2dup and [
- value-class swap value-class class-or
+: longest-vector ( list -- length )
+ [ vector-length ] map [ > ] top ;
+
+: computed-value-vector ( n -- vector )
+ [ drop object <computed> ] vector-project ;
+
+: add-inputs ( count stack -- count stack )
+ #! Add this many inputs to the given stack.
+ [ vector-length - dup ] keep
+ >r computed-value-vector dup r> vector-append ;
+
+: unify-lengths ( list -- list )
+ #! Pad all vectors to the same length. If one vector is
+ #! shorter, pad it with unknown results at the bottom.
+ dup longest-vector swap [ dupd add-inputs nip ] map nip ;
+
+: unify-results ( list -- value )
+ #! If all values in list are equal, return the value.
+ #! Otherwise, unify types.
+ dup all=? [
+ car
] [
- 2drop object
+ [ value-class ] map class-or-list <computed>
] ifte ;
-: unify-results ( value value -- value )
- #! Replace values with unknown result if they differ,
- #! otherwise retain them.
- 2dup = [
- drop
- ] [
- unify-classes <computed>
- ] ifte ;
+: vector-transpose ( list -- vector )
+ #! Turn a list of same-length vectors into a vector of lists.
+ dup car vector-length [
+ over [ dupd vector-nth ] map nip
+ ] vector-project nip ;
: unify-stacks ( list -- stack )
#! Replace differing literals in stacks with unknown
#! results.
- uncons [
- unify-length vector-zip [
- uncons unify-results
- ] vector-map
- ] each ;
+ unify-lengths vector-transpose [ unify-results ] vector-map ;
: balanced? ( list -- ? )
#! Check if a list of [ instack | outstack ] pairs is
meta-d off meta-r off d-in off
] when ;
+: propagate-type ( [ value | class ] -- )
+ #! Type propagation is chained.
+ [
+ unswons 2dup set-value-class
+ [ type-propagations get ] bind assoc propagate-type
+ ] when* ;
+
: infer-branch ( value -- namespace )
<namespace> [
- uncons [ unswons set-value-class ] when*
+ uncons propagate-type
dup value-recursion recursive-state set
copy-inference
literal-value dup infer-quot
#! Infer effects for all branches, unify.
[ object vector ] ensure-d
dataflow-drop, pop-d vtable>list
- [ f cons ] map
>r 1 meta-d get vector-tail* #dispatch r>
- pop-d drop ( n )
+ pop-d ( n ) num-types [ dupd cons ] project nip zip
infer-branches ;
USE: kernel-internals
! Recursive state. An alist, mapping words to labels.
SYMBOL: recursive-state
-! A value has the following slots:
GENERIC: literal-value ( value -- obj )
GENERIC: value= ( literal value -- ? )
GENERIC: value-class ( value -- class )
GENERIC: value-class-and ( class value -- )
GENERIC: set-value-class ( class value -- )
+! A value has the following slots in addition to those relating
+! to generics above:
+
+! An association list mapping values to [ value | class ] pairs
+SYMBOL: type-propagations
+
TRAITS: computed
C: computed ( class -- value )
[
\ value-class set
gensym \ literal-value set
+ type-propagations off
] extend ;
M: computed literal-value ( value -- obj )
"Cannot use a computed value literally." throw ;
TRAITS: literal
C: literal ( obj rstate -- value )
- [ recursive-state set \ literal-value set ] extend ;
+ [
+ recursive-state set
+ \ literal-value set
+ type-propagations off
+ ] extend ;
M: literal literal-value ( value -- obj )
[ \ literal-value get ] bind ;
M: literal value= ( literal value -- ? )
USE: vectors
USE: words
USE: stdio
+USE: prettyprint
! Enhanced inference of primitives relating to data types.
! Optimizes type checks and slot access.
: infer-check ( assert class -- )
peek-d dup value-class pick = [
- [
- "Optimized out " , rot word-name , " check." ,
- ] make-string print 2drop
+ 3drop
] [
value-class-and
dup "infer-effect" word-property consume/produce
] "infer" set-word-property
\ slot [
+ [ object fixnum ] ensure-d
dataflow-drop, pop-d literal-value
peek-d value-class builtin-supertypes dup length 1 = [
cons #slot dataflow, [
"slot called without static type knowledge" throw
] ifte
] "infer" set-word-property
+
+: type-value-map ( value -- )
+ [
+ num-types [
+ dup builtin-type dup [
+ pick swons cons ,
+ ] [
+ 2drop
+ ] ifte
+ ] times*
+ ] make-list nip ;
+
+\ type [
+ [ object ] ensure-d
+ \ type #call dataflow, [
+ peek-d type-value-map >r
+ 1 0 node-inputs
+ [ object ] consume-d
+ [ fixnum ] produce-d
+ r> peek-d [ type-propagations set ] bind
+ 1 0 node-outputs
+ ] bind
+] "infer" set-word-property
infer-compound
] ifte ;
+M: promise (apply-word) ( word -- )
+ "promise" word-property unit ensure-d ;
+
M: symbol (apply-word) ( word -- )
apply-literal ;
#! diverging recursion. Note that this check is not done for
#! mutually-recursive words. Generally they should be
#! avoided.
- recursive-state get car = [
+ current-word = [
d-in get vector-length
meta-d get vector-length > [
current-word word-name " diverges." cat2 throw
\ call [ infer-call ] "infer" set-word-property
+\ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
+
\ undefined-method t "terminator" set-word-property
\ not-a-number t "terminator" set-word-property
\ throw t "terminator" set-word-property
USE: vectors
: dispatch ( n vtable -- )
+ #! This word is unsafe in compiled code since n is not
+ #! bounds-checked. Do not call it directly.
vector-nth call ;
IN: kernel
GENERIC: real ( #{ re im } -- re )
M: real real ;
-M: complex real 0 slot ;
+M: complex real 0 slot %real ;
GENERIC: imaginary ( #{ re im } -- im )
M: real imaginary drop 0 ;
-M: complex imaginary 1 slot ;
+M: complex imaginary 1 slot %real ;
: rect> ( xr xi -- x )
over real? over real? and [
GENERIC: numerator ( a/b -- a )
M: integer numerator ;
-M: ratio numerator 0 slot ;
+M: ratio numerator 0 slot %integer ;
GENERIC: denominator ( a/b -- b )
M: integer denominator drop 1 ;
-M: ratio denominator 1 slot ;
+M: ratio denominator 1 slot %integer ;
IN: math-internals
[ sbuf-reverse " sbuf -- " [ [ sbuf ] [ ] ] ]
[ sbuf-clone " sbuf -- sbuf " [ [ sbuf ] [ sbuf ] ] ]
[ sbuf= " sbuf sbuf -- ? " [ [ sbuf sbuf ] [ boolean ] ] ]
- [ sbuf-hashcode " sbuf -- n " [ [ sbuf ] [ integer ] ] ]
+ [ sbuf-hashcode " sbuf -- n " [ [ sbuf ] [ fixnum ] ] ]
[ arithmetic-type " n n -- type " [ [ number number ] [ number number fixnum ] ] ]
[ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ]
[ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ]
! Define methods bound to primitives
BUILTIN: string 12
-M: string hashcode 2 slot ;
+M: string hashcode 2 slot %fixnum ;
M: string = str= ;
: str-length ( str -- len ) >string 1 integer-slot ; inline
: inline-test
car car ; inline
-[ t ] [
- \ slot [ inline-test ] dataflow dataflow-contains-param? >boolean
-] unit-test
+! [ t ] [
+! \ slot [ inline-test ] dataflow dataflow-contains-param? >boolean
+! ] unit-test
[ t ] [
#ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
[ [ vector ] [ cons vector cons integer object cons ] ]
[ [ vector ] [ cons vector cons ] ]
decompose
-]
+] unit-test
[ [ [ object ] [ object ] ] ]
[
[ [ object number ] [ object ] ]
[ [ object number ] [ object ] ]
decompose
-]
+] unit-test
: old-effect ( [ in-types out-types ] -- [ in | out ] )
uncons car length >r length r> cons ;
-[
- [ 1 | 2 ]
- [ 2 | 1 ]
- [ 0 | 3 ]
- [ 4 | 2 ]
- [ 3 | 3 ]
- [ 0 | 0 ]
- [ 1 | 5 ]
- [ 3 | 4 ]
-] "effects" set
-
-[ { f 1 2 } { 1 2 3 } ] [
- { 1 2 } { 1 2 3 } unify-length
-] unit-test
-
-[ [ sq ] ] [
- [ sq ] f <literal> [ sq ] f <literal> unify-results literal-value
-] unit-test
-
-[ fixnum ] [
- 5 f <literal> 6 f <literal> unify-results value-class
-] unit-test
-
[ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer old-effect ] unit-test
[ [ 1 | 2 ] ] [ [ dup ] infer old-effect ] unit-test
[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer old-effect ] unit-test
-: bad-recursion-1
- dup [ drop bad-recursion-1 5 ] [ ] ifte ;
-
-[ [ bad-recursion-1 ] infer old-effect ] unit-test-fails
+! : bad-recursion-1
+! dup [ drop bad-recursion-1 5 ] [ ] ifte ;
+!
+! [ [ bad-recursion-1 ] infer old-effect ] unit-test-fails
: bad-recursion-2
dup [ uncons bad-recursion-2 ] [ ] ifte ;
! Type inference
-! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
-! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
-! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
-! [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
-! [ [ [ object ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
-! [ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
+[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+[ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
+[ [ [ vector ] [ vector ] ] ] [ [ vector-clone ] infer ] unit-test
! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
+[ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
BUILTIN: word 1
-M: word hashcode 1 slot ;
+M: word hashcode 1 slot %fixnum ;
: word-xt ( w -- xt ) >word 2 integer-slot ; inline
: set-word-xt ( xt w -- ) >word 2 set-integer-slot ; inline
: intern-symbol ( word -- )
dup undefined? [ define-symbol ] [ drop ] ifte ;
-: word-name ( word -- str ) "name" word-property ;
+#! The type declaration is for the benefit of stack effect
+#! inference.
+: word-name ( word -- str )
+ "name" word-property >string ;
+
: word-vocabulary ( word -- str ) "vocabulary" word-property ;
: stack-effect ( word -- str ) "stack-effect" word-property ;
: documentation ( word -- str ) "documentation" word-property ;
projects / factor.git / commitdiff