diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8aa8c2b966..86e5218c39 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,10 +1,16 @@ + compiler: -- type inference fails with some assembler words -- more accurate type inference in some cases +- investigate why : foo t or ; doesn't partially evaluate +- investigate why ' doesn't infer +- recursive? and tree-contains? should handle vectors +- type inference and recursion flaw +- type inference fails with some assembler words; + displaced, register and other predicates need to inherit from list + not cons, and need stronger branch partial eval +- more accurate type inference in some cases - optimize away dispatch -- goal: to compile hash* optimally -- type check/not-check entry points for compiled words +- goal: to compile hash* optimally +- type check/not-check entry points for compiled words - getenv/setenv: if literal arg, compile as a load/store + oop: @@ -23,33 +29,39 @@ + listener/plugin: +- update plugin docs +- extract word keeps indent +- word preview for remote words - WordPreview calls markTokens() -> NPE -- stream server can hang because of exception handler limitations - listener should be multithreaded -- compile all, infer all commands +- compile all commands - faster completion -- errors don't always disappear - NPE in ErrorHighlight - maple-like: press enter at old commands to evaluate there - completion in the listener - special completion for USE:/IN: ++ i/o: + +- stream server can hang because of exception handler limitations +- better i/o scheduler +- nicer way to combine two paths +- add a socket timeout +- rename f* words to stream-* +- is badly named -- , + + kernel: - ppc register decls - do partial objects cause problems? -- better i/o scheduler - remove sbufs - cat, reverse-cat primitives - first-class hashtables -- add a socket timeout + misc: - perhaps /i should work with all numbers -- unit test weirdness: 2 lines appears at end - jedit ==> jedit-word, jedit takes a file name -- nicer way to combine two paths - browser responder for word links in HTTPd - worddef props - prettyprint: when unparse called due to recursion, write a link diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 0fcbe52aae..063d21bbfb 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -215,7 +215,7 @@ M: f ' ( obj -- ptr ) : transfer-word ( word -- word ) #! This is a hack. See doc/bootstrap.txt. dup dup word-name swap word-vocabulary unit search - [ "Missing DEFER: " word-error ] ?unless ; + [ dup "Missing DEFER: " word-error ] ?unless ; : fixup-word ( word -- offset ) dup pooled-object [ "Not in image: " word-error ] ?unless ; diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index 1984809768..01e8f8d91c 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -105,7 +105,7 @@ M: register register "register" word-property ; M: register displacement drop ; ( Indirect register operands -- eg, [ ECX ] ) -PREDICATE: list indirect +PREDICATE: cons indirect dup length 1 = [ car register? ] [ drop f ] ifte ; M: indirect modifier drop BIN: 00 ; @@ -117,7 +117,7 @@ M: indirect register M: indirect displacement drop ; ( Displaced indirect register operands -- eg, [ EAX 4 ] ) -PREDICATE: list displaced +PREDICATE: cons displaced dup length 2 = [ 2unlist integer? swap register? and ] [ @@ -130,7 +130,7 @@ M: displaced displacement cdr car dup byte? [ compile-byte ] [ compile-cell ] ifte ; ( Displacement-only operands -- eg, [ 1234 ] ) -PREDICATE: list disp-only +PREDICATE: cons disp-only dup length 1 = [ car integer? ] [ drop f ] ifte ; M: disp-only modifier drop BIN: 00 ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index cdc1f6dd61..b8e341897b 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -135,7 +135,7 @@ USE: math-internals [ ECX ] IDIV EAX 3 SHL 0 JNO fixup - \ fixnum/i compile-call + \ fixnum/mod compile-call 0 JMP fixup >r compiled-offset swap patch [ ECX -4 ] EAX MOV diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 3e725e40e1..bf66244b2d 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -47,7 +47,7 @@ USE: prettyprint : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. - dup >r vector-length - computed-value-vector dup r> + [ vector-length - computed-value-vector ] keep vector-append ; : unify-lengths ( list -- list ) @@ -89,7 +89,7 @@ USE: prettyprint ] ifte ; : datastack-effect ( list -- ) - [ [ d-in get meta-d get ] bind cons ] map + [ [ effect ] bind ] map unify-effect meta-d set d-in set ; @@ -161,7 +161,7 @@ SYMBOL: cloned #! for the given branch. [ [ - inferring-base-case get [ + branches-can-fail? [ [ infer-branch , ] [ @@ -182,7 +182,7 @@ SYMBOL: cloned #! the branches has an undecidable stack effect, we set the #! base case to this stack effect and try again. The inputs #! parameter is a vector. - (infer-branches) dup unify-effects unify-dataflow ; + (infer-branches) dup unify-effects unify-dataflow ; : (with-block) ( label quot -- ) #! Call a quotation in a new namespace, and transfer @@ -196,7 +196,7 @@ SYMBOL: cloned meta-r set meta-d set d-in set ; : static-branch? ( value -- ) - literal? inferring-base-case get not and ; + literal? branches-can-fail? not and ; : static-ifte ( true false -- ) #! If the branch taken is statically known, just infer @@ -222,11 +222,11 @@ SYMBOL: cloned [ object general-list general-list ] ensure-d dataflow-drop, pop-d dataflow-drop, pop-d swap -! peek-d static-branch? [ -! static-ifte -! ] [ + peek-d static-branch? [ + static-ifte + ] [ dynamic-ifte - ( ] ifte ) ; + ] ifte ; \ ifte [ infer-ifte ] "infer" set-word-property diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 2ee4c4c9b8..02dd8fda87 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -39,10 +39,18 @@ USE: hashtables USE: generic USE: prettyprint -! If this symbol is on, partial evalution of conditionals is +! If this variable is on, partial evalution of conditionals is ! disabled. SYMBOL: inferring-base-case +! If this variable is on, we are inferring the entry effect, so +! we unify all entry point effects to the vecto stored in this +! variable. +SYMBOL: inferring-entry-effect + +: branches-can-fail? ( -- ? ) + inferring-base-case get inferring-entry-effect get or ; + ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs ! expected, and number of outputs produced. @@ -130,7 +138,7 @@ M: literal set-value-class ( class value -- ) ] ifte ; : vector-prepend ( values stack -- stack ) - >r list>vector dup r> vector-append ; + >r list>vector r> vector-append ; : ensure-d ( typelist -- ) dup meta-d get ensure-types @@ -138,17 +146,23 @@ M: literal set-value-class ( class value -- ) meta-d [ vector-prepend ] change d-in [ vector-prepend ] change ; -: effect ( -- [ in-types out-types ] ) +: (present-effect) ( vector -- list ) + [ value-class ] vector-map vector>list ; + +: present-effect ( [ d-in | meta-d ] -- [ in-types out-types ] ) #! After inference is finished, collect information. - d-in get [ value-class ] vector-map vector>list - meta-d get [ value-class ] vector-map vector>list 2list ; + uncons >r (present-effect) r> (present-effect) 2list ; + +: effect ( -- [ d-in | meta-d ] ) + d-in get meta-d get cons ; : init-inference ( recursive-state -- ) init-interpreter 0 d-in set recursive-state set dataflow-graph off - inferring-base-case off ; + inferring-base-case off + inferring-entry-effect off ; DEFER: apply-word @@ -186,7 +200,7 @@ DEFER: apply-word : infer ( quot -- [ in | out ] ) #! Stack effect of a quotation. - [ (infer) effect ] with-scope ; + [ (infer) effect present-effect ] with-scope ; : dataflow ( quot -- dataflow ) #! Data flow of a quotation. diff --git a/library/inference/words.factor b/library/inference/words.factor index cc013eb1ed..9d870bf80d 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -88,17 +88,32 @@ USE: prettyprint r> call ] (with-block) ; +: entry-effect ( quot -- ) + [ + meta-d get inferring-entry-effect set + copy-inference + infer-quot + inferring-entry-effect off + ] with-scope ; + +: recursive? ( word -- ? ) + dup word-parameter tree-contains? ; + : inline-compound ( word -- effect ) #! Infer the stack effect of a compound word in the current - #! inferencer instance. - gensym [ word-parameter infer-quot effect ] with-block ; + #! inferencer instance. If the word in question is recursive + #! we infer its stack effect inside a new block. + gensym [ + dup recursive? [ dup word-parameter entry-effect ] when + word-parameter infer-quot effect + ] with-block ; : infer-compound ( word -- effect ) #! Infer a word's stack effect in a separate inferencer #! instance. [ recursive-state get init-inference - dup dup inline-compound + dup dup inline-compound present-effect [ "infer-effect" set-word-property ] keep ] with-scope consume/produce ; @@ -135,32 +150,77 @@ M: symbol (apply-word) ( word -- ) ] when ] when ; -: decompose ( x y -- effect ) +: decompose ( x y -- [ d-in | meta-d ] ) #! Return a stack effect such that x*effect = y. - 2unlist >r - swap 2unlist >r - over length over length - head nip - r> append - r> 2list ; + uncons >r swap uncons >r + over vector-length over vector-length - + swap vector-head nip + r> vector-append r> cons ; -: base-case ( word -- effect ) - effect swap +: base-case ( word -- [ d-in | meta-d ] ) [ inferring-base-case on copy-inference inline-compound inferring-base-case off - ] with-scope decompose ; + ] with-scope effect swap decompose ; + +: no-base-case ( word -- ) + word-name " does not have a base case." cat2 throw ; + +: raise# ( n vec -- n ) + #! Parameter is a vector of pairs. Return the highest index + #! where pairs are equal. + 2dup vector-length >= [ + drop + ] [ + 2dup vector-nth uncons = [ + >r 1 + r> raise# + ] [ + drop + ] ifte + ] ifte ; + +: raise ( vec1 vec2 -- list ) + #! Return a new vector consisting of the remainder of vec1, + #! without any leading elements equal to those from vec2. + over vector-zip 0 swap raise# swap vector-tail ; + +: unify-entry-effect ( vector list -- ) + #! If any elements are not equal, the vector's element is + #! replaced with the list's. + over vector-length over length - -rot [ + ( n vector elt ) + pick pick vector-nth over = [ + drop + ] [ + pick pick set-vector-nth + ] ifte + >r 1 + r> + ] each 2drop ; + +: apply-entry-effect ( word -- ) + #! Called at a recursive call point. We need this to compute + #! the set of literals that is retained across a recursive + #! call -- this is NOT the same as the literals present on + #! entry. This word mutates the inferring-entry-effect + #! vector. + base-case uncons raise + inferring-entry-effect get swap unify-entry-effect ; : recursive-word ( word label -- ) #! Handle a recursive call, by either applying a previously #! inferred base case, or raising an error. If the recursive #! call is to a local block, emit a label call node. inferring-base-case get [ - drop word-name " does not have a base case." cat2 throw + drop no-base-case ] [ - 2dup [ drop #call-label ] [ nip #call ] ifte - rot base-case (consume/produce) + inferring-entry-effect get [ + apply-entry-effect "Bail out" throw + ] [ + dup [ #call-label ] [ #call ] ?ifte + rot base-case present-effect (consume/produce) + ] ifte ] ifte ; : apply-word ( word -- ) @@ -186,6 +246,7 @@ M: symbol (apply-word) ( word -- ) \ call [ infer-call ] "infer" set-word-property +! These hacks will go away soon \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property \ undefined-method t "terminator" set-word-property diff --git a/library/test/inference.factor b/library/test/inference.factor index bd4534aca8..af754a2219 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -11,23 +11,35 @@ USE: kernel USE: math-internals USE: generic -[ [ [ object object ] f ] ] -[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] +[ 0 ] +[ { 1 2 3 } { 4 5 6 } vector-zip 0 swap raise# ] unit-test -[ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] -[ - [ [ vector ] [ cons vector cons integer object cons ] ] - [ [ vector ] [ cons vector cons ] ] - decompose -] unit-test +[ 2 ] +[ { 1 2 3 } { 1 2 6 } vector-zip 0 swap raise# ] +unit-test -[ [ [ object ] [ object ] ] ] -[ - [ [ object number ] [ object ] ] - [ [ object number ] [ object ] ] - decompose -] unit-test +[ { 4 5 6 } ] +[ { 1 2 3 } dup [ 4 5 6 ] unify-entry-effect ] +unit-test + +! [ [ [ object object ] f ] ] +! [ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ] +! unit-test +! +! [ [ [ cons vector cons integer object cons ] [ cons vector cons ] ] ] +! [ +! [ [ 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 ; diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 4cb177480e..7a9a2e1a3b 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -50,7 +50,7 @@ USE: namespaces [ t ] [ { } hashcode { } hashcode = ] unit-test [ { 1 2 3 4 5 6 } ] -[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test +[ { 1 2 3 } { 4 5 6 } vector-append ] unit-test [ { "" "a" "aa" "aaa" } ] [ 4 [ CHAR: a fill ] vector-project ] diff --git a/library/vectors.factor b/library/vectors.factor index 93e9e7d7d0..25c87c0b49 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -107,10 +107,15 @@ BUILTIN: vector 11 : vector-all? ( vector pred -- ? ) vector-map vector-and ; inline -: vector-append ( v1 v2 -- ) +: vector-nappend ( v1 v2 -- ) #! Destructively append v2 to v1. [ over vector-push ] vector-each drop ; +: vector-append ( v1 v2 -- vec ) + over vector-length over vector-length + + [ rot vector-nappend ] keep + [ swap vector-nappend ] keep ; + : vector-project ( n quot -- accum ) #! Execute the quotation n times, passing the loop counter #! the quotation as it ranges from 0..n-1. Collect results @@ -122,7 +127,7 @@ BUILTIN: vector 11 : vector-zip ( v1 v2 -- v ) #! Make a new vector with each pair of elements from the #! first two in a pair. - over vector-length [ + over vector-length over vector-length min [ pick pick >r over >r vector-nth r> r> vector-nth cons ] vector-project nip nip ; @@ -168,8 +173,13 @@ M: vector hashcode ( vec -- n ) over ?vector-nth hashcode rot bitxor swap ] times* drop ; +: vector-head ( n vector -- list ) + #! Return a new list with all elements up to the nth + #! element. + swap [ over vector-nth ] vector-project nip ; + : vector-tail ( n vector -- list ) - #! Return a new vector, with all elements from the nth + #! Return a new list with all elements from the nth #! index upwards. 2dup vector-length swap - [ pick + over vector-nth