: (each) ( list quot -- list quot )
[ >r car r> call ] 2keep >r cdr r> ; inline
-M: general-list each ( list quot -- )
- #! Push each element of a proper list in turn, and apply a
- #! quotation with effect ( elt -- ) to each element.
- over [ (each) each ] [ 2drop ] ifte ;
+M: f each ( list quot -- ) 2drop ;
+
+M: cons each ( list quot -- | quot: elt -- ) (each) each ;
M: cons tree-each ( cons quot -- )
>r uncons r> tuck >r >r tree-each r> r> tree-each ;
M: general-list reverse ( list -- list )
[ ] swap [ swons ] each ;
-M: general-list map ( list quot -- list )
- #! Push each element of a proper list in turn, and collect
- #! return values of applying a quotation with effect
- #! ( X -- Y ) to each element into a new list.
- over [ (each) rot >r map r> swons ] [ drop ] ifte ;
+M: f map ( list quot -- list ) drop ;
+
+M: cons map ( list quot -- list | quot: elt -- elt )
+ (each) rot >r map r> swons ;
: remove ( obj list -- list )
#! Remove all occurrences of objects equal to this one from
M: cons hashcode ( cons -- hash ) car hashcode ;
-: (count) ( i n -- list )
- 2dup >= [ 2drop [ ] ] [ >r dup 1 + r> (count) cons ] ifte ;
-
: count ( n -- [ 0 ... n-1 ] )
- 0 swap (count) ;
+ 0 swap <range> >list ;
: project ( n quot -- list )
>r count r> map ; inline
G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
[ over ] [ type ] ; inline
+DEFER: <range>
DEFER: append ! remove this when sort is moved from lists to sequences
! Some low-level code used by vectors and string buffers.
#! Execute the quotation n times, passing the loop counter
#! the quotation as it ranges from 0..n-1. Collect results
#! in a new vector.
- project >vector ; inline
+ >r 0 swap <range> >vector r> map ; inline
: zero-vector ( n -- vector )
[ drop 0 ] vector-project ;
: typed? ( value -- ? ) value-types length 1 = ;
-: self ( word -- )
- f swap dup "infer-effect" word-prop (consume/produce) ;
-
-: intrinsic ( word -- )
- dup [ literal, \ self , ] make-list "infer" set-word-prop ;
-
-\ slot intrinsic
+\ slot t "intrinsic" set-word-prop
: slot@ ( node -- n )
#! Compute slot offset.
] ifte out-1
] "linearizer" set-word-prop
-\ set-slot intrinsic
+\ set-slot t "intrinsic" set-word-prop
\ set-slot [
dup typed-literal? [
] ifte
] "linearizer" set-word-prop
-\ type intrinsic
+\ type t "intrinsic" set-word-prop
\ type [
drop
out-1
] "linearizer" set-word-prop
-\ arithmetic-type intrinsic
+\ arithmetic-type t "intrinsic" set-word-prop
\ arithmetic-type [
drop
out-1
] "linearizer" set-word-prop
-\ getenv intrinsic
+\ getenv t "intrinsic" set-word-prop
\ getenv [
1 %dec-d ,
out-1
] "linearizer" set-word-prop
-\ setenv intrinsic
+\ setenv t "intrinsic" set-word-prop
\ setenv [
1 %dec-d ,
[[ fixnum> %fixnum> ]]
[[ eq? %eq? ]]
] [
- uncons over intrinsic
+ uncons over t "intrinsic" set-word-prop
[ literal, 0 , \ binary-op , ] make-list
"linearizer" set-word-prop
] each
-\ fixnum* intrinsic
+\ fixnum* t "intrinsic" set-word-prop
: slow-fixnum* \ %fixnum* 0 binary-op-reg ;
] ifte
] "linearizer" set-word-prop
-\ fixnum-mod intrinsic
+\ fixnum-mod t "intrinsic" set-word-prop
\ fixnum-mod [
! This is not clever. Because of x86, %fixnum-mod is
drop \ %fixnum-mod 2 binary-op-reg
] "linearizer" set-word-prop
-\ fixnum/i intrinsic
+\ fixnum/i t "intrinsic" set-word-prop
\ fixnum/i [
drop \ %fixnum/i 0 binary-op-reg
] "linearizer" set-word-prop
-\ fixnum/mod intrinsic
+\ fixnum/mod t "intrinsic" set-word-prop
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
0 1 %replace-d ,
] "linearizer" set-word-prop
-\ fixnum-bitnot intrinsic
+\ fixnum-bitnot t "intrinsic" set-word-prop
\ fixnum-bitnot [
drop
] ifte
] ifte ;
-\ fixnum-shift intrinsic
+\ fixnum-shift t "intrinsic" set-word-prop
\ fixnum-shift [
node-peek dup literal? [
dup intern-symbol
dup r> "builtin-type" set-word-prop
dup builtin define-class
- dup r> set-predicate
+ dup r> unit "predicate" set-word-prop
dup builtin-predicate
dup r> define-slots
register-builtin ;
! A simple single-dispatch generic word system.
-: predicate-word ( word -- word ) word-name "?" cat2 create-in ;
+: predicate-word ( word -- word )
+ word-name "?" cat2 create-in
+ dup t "inline" set-word-prop ;
! Terminology:
! - type: a datatype built in to the runtime, eg fixnum, word
dup builtin-supertypes [ > ] sort
typemap get set-hash ;
-: set-predicate ( class word -- )
- dup t "inline" set-word-prop
- unit "predicate" set-word-prop ;
-
typemap get [ <namespace> typemap set ] unless
: class-tuple 2 slot ; inline
-! A sequence of all slots in a tuple, used for equality testing.
-TUPLE: tuple-seq tuple ;
-
-M: tuple-seq nth ( n tuple-seq -- elt )
- tuple-seq-tuple array-nth ;
-
-M: tuple-seq length ( tuple-seq -- len )
- tuple-seq-tuple array-capacity ;
-
IN: generic
DEFER: tuple?
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
- dup predicate-word 2dup set-predicate
+ dup predicate-word 2dup unit "predicate" set-word-prop
swap [
[ dup tuple? ] %
[ \ class-tuple , literal, \ eq? , ] make-list ,
: add-tuple-dispatch ( word vtable -- )
>r tuple-dispatch-quot tuple r> set-vtable ;
-: tuple>list ( tuple -- list )
- #! We have to type check here, since <tuple-seq> is unsafe.
- dup tuple? [
- <tuple-seq> >list
+! A sequence of all slots in a tuple, used for equality testing.
+TUPLE: mirror tuple ;
+
+C: mirror ( tuple -- mirror )
+ over tuple? [
+ [ set-mirror-tuple ] keep
] [
"Not a tuple" throw
] ifte ;
+M: mirror nth ( n mirror -- elt )
+ bounds-check mirror-tuple array-nth ;
+
+M: mirror set-nth ( n mirror -- elt )
+ bounds-check mirror-tuple set-array-nth ;
+
+M: mirror length ( mirror -- len )
+ mirror-tuple array-capacity ;
+
+: tuple>list ( tuple -- list )
+ #! We have to type check here, since <mirror> is unsafe.
+ <mirror> >list ;
+
: clone-tuple ( tuple -- tuple )
#! Make a shallow copy of a tuple, without cloning its
#! delegate.
2drop t
] [
over tuple? [
- swap <tuple-seq> swap <tuple-seq> sequence=
+ swap <mirror> swap <mirror> sequence=
] [
2drop f
] ifte
SYMBOL: cloned
+GENERIC: (deep-clone)
+
: deep-clone ( obj -- obj )
- #! Clone an object if it hasn't already been cloned in this
- #! with-deep-clone scope.
dup cloned get assq [ ] [
- dup clone [ swap cloned [ acons ] change ] keep
+ dup (deep-clone) [ swap cloned [ acons ] change ] keep
] ?ifte ;
-: deep-clone-seq ( seq -- seq )
+M: tuple (deep-clone) ( obj -- obj )
+ #! Clone an object if it hasn't already been cloned in this
+ #! with-deep-clone scope.
+ clone dup <mirror> [ deep-clone ] nmap ;
+
+M: vector (deep-clone) ( seq -- seq )
#! Clone a sequence and each object it contains.
[ deep-clone ] map ;
+M: cons (deep-clone) ( cons -- cons )
+ uncons deep-clone >r deep-clone r> cons ;
+
+M: object (deep-clone) ( obj -- obj ) ;
+
: copy-inference ( -- )
#! We avoid cloning the same object more than once in order
#! to preserve identity structure.
cloned off
- meta-r [ deep-clone-seq ] change
- meta-d [ deep-clone-seq ] change
- d-in [ deep-clone-seq ] change
+ meta-r [ deep-clone ] change
+ meta-d [ deep-clone ] change
+ d-in [ deep-clone ] change
dataflow-graph off ;
: infer-branch ( value -- namespace )
#! meta-d, meta-r, d-in. They are set to f if
#! terminate was called.
<namespace> [
- uncons pull-tie
- dup value-recursion recursive-state set
copy-inference
+ uncons deep-clone pull-tie
+ cloned off
+ dup value-recursion recursive-state set
literal-value dup infer-quot
active? [
#values values-node
#! base case to this stack effect and try again.
(infer-branches) dup unify-effects unify-dataflow ;
+: boolean-value? ( value -- ? )
+ #! Return if the value's boolean valuation is known.
+ value-class dup \ f = >r \ f class-and null = r> or ;
+
+: boolean-value ( value -- ? )
+ #! Only valid if boolean? returns true.
+ value-class \ f = not ;
+
+: static-ifte? ( value -- ? )
+ #! Is the outcome of this branch statically known?
+ dup value-safe? swap boolean-value? and ;
+
+: static-ifte ( true false -- )
+ #! If the branch taken is statically known, just infer
+ #! along that branch.
+ 1 dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte
+ >literal< infer-quot-value ;
+
: infer-ifte ( true false -- )
#! If branch taken is computed, infer along both paths and
#! unify.
2list >r pop-d \ ifte r>
- pick [ general-t POSTPONE: f ] [ <class-tie> ] map-with
+ pick [ POSTPONE: f general-t ] [ <class-tie> ] map-with
zip ( condition )
infer-branches ;
\ ifte [
- 2 dataflow-drop, pop-d pop-d swap infer-ifte
+ 2 dataflow-drop, pop-d pop-d swap
+ peek-d static-ifte? [
+ static-ifte
+ ] [
+ infer-ifte
+ ] ifte
] "infer" set-word-prop
: vtable>list ( rstate vtable -- list )
over length [ <literal-tie> ] project-with
zip infer-branches ;
-\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
+\ dispatch [
+ pop-literal infer-dispatch
+] "infer" set-word-prop
+
\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
SYMBOL: d-in
: pop-literal ( -- rstate obj )
- 1 dataflow-drop, pop-d
- dup value-recursion swap literal-value ;
+ 1 dataflow-drop, pop-d >literal< ;
: (ensure-types) ( typelist n stack -- )
pick [
drop
] ifte ;
+: infer-quot-value ( rstate quot -- )
+ recursive-state get >r
+ swap recursive-state set
+ dup infer-quot handle-terminator
+ r> recursive-state set ;
+
: check-active ( -- )
active? [ "Provable runtime error" inference-error ] unless ;
sequences words ;
: literal-inputs? ( in stack -- )
- tail-slice dup >list [ literal-safe? ] all? [
+ tail-slice dup >list [ safe-literal? ] all? [
length dataflow-drop, t
] [
drop f
stateless
] each
+: eq-tie ( v1 v2 bool -- )
+ >r swap literal-value <literal-tie> general-t swons unit r>
+ set-value-class-ties ;
+
+: eq-ties ( v1 v2 bool -- )
+ #! If the boolean is true, the values are equal.
+ pick literal? [
+ eq-tie
+ ] [
+ over literal? [
+ swapd eq-tie
+ ] [
+ 3drop
+ ] ifte
+ ] ifte ;
+
+\ eq? [
+ peek-d peek-next-d
+ \ eq? infer-eval
+ peek-d eq-ties
+] "infer" set-word-prop
+
! Partially-evaluated words need their stack effects to be
! entered by hand.
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
TUPLE: literal-tie value literal ;
M: literal-tie pull-tie ( tie -- )
dup literal-tie-literal swap literal-tie-value
- 2dup set-literal-value
+ dup literal? [ 2dup set-literal-value ] when
value-literal-ties assoc pull-tie ;
M: f pull-tie ( tie -- )
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
-USING: errors generic interpreter kernel kernel-internals
-lists math namespaces strings vectors words sequences
-stdio prettyprint ;
+USING: generic interpreter kernel lists math namespaces words ;
: type-value-map ( value -- )
num-types
[ cdr class-tie-class ] subset ;
: infer-type ( -- )
- \ type #call dataflow, [
+ f \ type dataflow, [
peek-d type-value-map >r
1 0 node-inputs
[ object ] consume-d
1 0 node-outputs
] bind ;
+: type-known? ( value -- ? )
+ dup value-safe? swap value-types cdr not and ;
+
\ type [
- [ object ] ensure-d infer-type
+ peek-d type-known? [
+ 1 dataflow-drop, pop-d value-types car apply-literal
+ ] [
+ infer-type
+ ] ifte
] "infer" set-word-prop
GENERIC: value= ( literal value -- ? )
GENERIC: value-class-and ( class value -- )
+GENERIC: safe-literal? ( value -- ? )
-TUPLE: value class recursion class-ties literal-ties ;
+TUPLE: value class recursion class-ties literal-ties safe? ;
C: value ( recursion -- value )
+ [ t swap set-value-safe? ] keep
[ set-value-recursion ] keep ;
TUPLE: computed ;
value-class failing-class-and
] keep set-value-class ;
-TUPLE: literal value safe? ;
+TUPLE: literal value ;
C: literal ( obj rstate -- value )
- [ t swap set-literal-safe? ] keep
[
>r <value> [ >r dup class r> set-value-class ] keep
r> set-delegate
M: literal set-value-class ( class value -- )
2drop ;
-M: computed literal-safe? drop f ;
+M: literal safe-literal? ( value -- ? ) value-safe? ;
-M: computed set-literal-safe? 2drop ;
+M: computed safe-literal? drop f ;
M: computed literal-value ( value -- )
"A literal value was expected where a computed value was"
: value-types ( value -- list )
value-class builtin-supertypes ;
+
+: >literal< ( literal -- rstate obj )
+ dup value-recursion swap literal-value ;
: consume/produce ( word [ in-types out-types ] -- )
#! Add a node to the dataflow graph that consumes and
#! produces a number of values.
- #call swap (consume/produce) ;
+ over "intrinsic" word-prop [
+ f -rot
+ ] [
+ #call swap
+ ] ifte (consume/produce) ;
: no-effect ( word -- )
"Unknown stack effect: " swap word-name cat2 inference-error ;
: inhibit-parital ( -- )
- meta-d get [ f swap set-literal-safe? ] each ;
+ meta-d get [ f swap set-value-safe? ] each ;
: recursive? ( word -- ? )
f swap dup word-def [ = or ] tree-each-with ;
apply-word
] ifte* ;
-: infer-quot-value ( rstate quot -- )
- recursive-state get >r
- swap recursive-state set
- dup infer-quot handle-terminator
- r> recursive-state set ;
-
\ call [
pop-literal infer-quot-value
] "infer" set-word-prop
\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ not-a-number t "terminator" set-word-prop
+\ inference-error t "terminator" set-word-prop
\ throw t "terminator" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
[ [ call ] infer old-effect ] unit-test-fails
[ [[ 2 4 ]] ] [ [ 2dup ] infer old-effect ] unit-test
-[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
[ [[ 1 0 ]] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test
[ [ ifte ] infer old-effect ] unit-test-fails
[ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test
-
+[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test
[ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test
[ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test
[ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test
-! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
-! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
-! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
-!
-! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
+[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
+[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test
+
+[ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test
TUPLE: funny-cons car cdr ;
GENERIC: iterate
projects / factor.git / commitdiff