From 6f1dc49fa8a36d4f865fb0ccfbd29f0d0cab7a9c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Feb 2008 20:07:08 -0600 Subject: [PATCH 01/58] Fix bug and clean up optimizer --- core/optimizer/backend/backend.factor | 356 +----------------- core/optimizer/control/control.factor | 255 ++++++++++++- core/optimizer/inlining/inlining.factor | 227 +++++++++++ core/optimizer/known-words/known-words.factor | 2 +- core/optimizer/math/math.factor | 2 +- core/optimizer/optimizer-tests.factor | 2 +- core/optimizer/optimizer.factor | 2 +- 7 files changed, 484 insertions(+), 362 deletions(-) mode change 100644 => 100755 core/optimizer/control/control.factor create mode 100755 core/optimizer/inlining/inlining.factor diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index a8645787a1..3fe3a3e25f 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -3,8 +3,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables -combinators classes generic.math continuations optimizer.def-use -optimizer.pattern-match generic.standard optimizer.specializers ; +combinators classes optimizer.def-use ; IN: optimizer.backend SYMBOL: class-substitutions @@ -76,7 +75,6 @@ DEFER: optimize-nodes optimizer-changed get ] with-scope optimizer-changed set ; -! Generic nodes M: node optimize-node* drop t f ; ! Post-inlining cleanup @@ -112,362 +110,10 @@ M: #return optimize-node* cleanup-inlining ; ! #values M: #values optimize-node* cleanup-inlining ; -! Some utilities for splicing in dataflow IR subtrees M: f set-node-successor 2drop ; : splice-node ( old new -- ) dup splice-def-use last-node set-node-successor ; -GENERIC: remember-method* ( method-spec node -- ) - -M: #call remember-method* - [ node-history ?push ] keep set-node-history ; - -M: node remember-method* - 2drop ; - -: remember-method ( method-spec node -- ) - swap dup second +inlined+ depends-on - [ swap remember-method* ] curry each-node ; - -: (splice-method) ( #call method-spec quot -- node ) - #! Must remember the method before splicing in, otherwise - #! the rest of the IR will also remember the method - pick node-in-d dataflow-with - [ remember-method ] keep - [ swap infer-classes/node ] 2keep - [ splice-node ] keep ; - -: splice-quot ( #call quot -- node ) - over node-in-d dataflow-with - [ swap infer-classes/node ] 2keep - [ splice-node ] keep ; - : drop-inputs ( node -- #shuffle ) node-in-d clone \ #shuffle in-node ; - -! Constant branch folding -: fold-branch ( node branch# -- node ) - over node-children nth - swap node-successor over splice-node ; - -! #if -: known-boolean-value? ( node value -- value ? ) - 2dup node-literal? [ - node-literal t - ] [ - node-class { - { [ dup null class< ] [ drop f f ] } - { [ dup general-t class< ] [ drop t t ] } - { [ dup \ f class< ] [ drop f t ] } - { [ t ] [ drop f f ] } - } cond - ] if ; - -: fold-if-branch? dup node-in-d first known-boolean-value? ; - -: fold-if-branch ( node value -- node' ) - over drop-inputs >r - 0 1 ? fold-branch - r> [ set-node-successor ] keep ; - -: only-one ( seq -- elt/f ) - dup length 1 = [ first ] [ drop f ] if ; - -: lift-throw-tail? ( #if -- tail/? ) - dup node-successor node-successor - [ active-children only-one ] [ drop f ] if ; - -: clone-node ( node -- newnode ) - clone dup [ clone ] modify-values ; - -: detach-node-successor ( node -- successor ) - dup node-successor #terminate rot set-node-successor ; - -: lift-branch ( #if node -- ) - >r detach-node-successor r> splice-node ; - -M: #if optimize-node* - dup fold-if-branch? [ fold-if-branch t ] [ - 2drop t f - ! drop dup lift-throw-tail? dup [ - ! dupd lift-branch t - ! ] [ - ! 2drop t f - ! ] if - ] if ; - -: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; - -: fold-dispatch-branch ( node value -- node' ) - dupd node-literal - over drop-inputs >r fold-branch r> - [ set-node-successor ] keep ; - -M: #dispatch optimize-node* - dup fold-dispatch-branch? [ - fold-dispatch-branch t - ] [ - 2drop t f - ] if ; - -! #loop - - -! BEFORE: - -! #label -> C -> #return 1 -! | -! -> #if -> #merge -> #return 2 -! | -! -------- -! | | -! A B -! | | -! #values | -! #call-label -! | -! | -! #values - -! AFTER: - -! #label -> #terminate -! | -! -> #if -> #terminate -! | -! -------- -! | | -! A B -! | | -! #values | -! | #call-label -! #merge | -! | | -! C #values -! | -! #return 1 - -: find-final-if ( node -- #if/f ) - dup [ - dup #if? [ - dup node-successor #tail? [ - node-successor find-final-if - ] unless - ] [ - node-successor find-final-if - ] if - ] when ; - -: lift-loop-tail? ( #label -- tail/f ) - dup node-successor node-successor [ - dup node-param swap node-child find-final-if dup [ - node-children [ penultimate-node ] map - [ - dup #call-label? - [ node-param eq? not ] [ 2drop t ] if - ] with subset only-one - ] [ 2drop f ] if - ] [ drop f ] if ; - -! M: #loop optimize-node* -! dup lift-loop-tail? dup [ -! last-node >r -! dup detach-node-successor -! over node-child find-final-if detach-node-successor -! [ set-node-successor ] keep -! r> set-node-successor -! t -! ] [ -! 2drop t f -! ] if ; - -! #call -: splice-method ( #call method-spec/t quot/t -- node/t ) - #! t indicates failure - { - { [ dup t eq? ] [ 3drop t ] } - { [ 2over swap node-history member? ] [ 3drop t ] } - { [ t ] [ (splice-method) ] } - } cond ; - -! Single dispatch method inlining optimization -: already-inlined? ( node -- ? ) - #! Was this node inlined from definition of 'word'? - dup node-param swap node-history memq? ; - -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; - -! A heuristic to avoid excessive inlining -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - dup get over inline? not or - [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 1+ ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } - } cond - ] map sum ; - -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; - -: will-inline-method ( node word -- method-spec/t quot/t ) - #! t indicates failure - tuck dispatching-class dup [ - swap [ 2array ] 2keep - method method-word - dup flat-length 10 >= - [ 1quotation ] [ word-def ] if - ] [ - 2drop t t - ] if ; - -: inline-standard-method ( node word -- node ) - dupd will-inline-method splice-method ; - -! Partial dispatch of math-generic words -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: will-inline-math-method ( word left right -- method-spec/t quot/t ) - #! t indicates failure - 3dup math-both-known? - [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ; - -: inline-math-method ( #call word -- node ) - over node-input-classes first2 - will-inline-math-method splice-method ; - -: inline-method ( #call -- node ) - dup node-param { - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } - } cond ; - -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class< >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - -: literal-quot ( node literals -- quot ) - #! Outputs a quotation which drops the node's inputs, and - #! pushes some literals. - >r node-in-d length \ drop - r> [ literalize ] map append >quotation ; - -: inline-literals ( node literals -- node ) - #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot splice-quot ; - -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class< ; - -: optimize-predicate ( #call -- node ) - dup evaluate-predicate swap - dup node-successor #if? [ - dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep - ] [ - swap 1array inline-literals - ] if ; - -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; - -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; - -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; - -: flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; - -: flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; - -: partial-eval? ( #call -- ? ) - dup node-param "foldable" word-prop [ - dup node-in-d [ node-literal? ] with all? - ] [ - drop f - ] if ; - -: literal-in-d ( #call -- inputs ) - dup node-in-d [ node-literal ] with map ; - -: partial-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup literal-in-d over node-param 1quotation - [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; - -: define-identities ( words identities -- ) - [ "identities" set-word-prop ] curry each ; - -: find-identity ( node -- quot ) - [ node-param "identities" word-prop ] keep - [ swap first in-d-match? ] curry find - nip dup [ second ] when ; - -: apply-identities ( node -- node/f ) - dup find-identity dup [ splice-quot ] [ 2drop f ] if ; - -: optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ types length 1 = ] all? - ] [ - 2drop f - ] if ; - -: optimistic-inline ( #call -- node ) - dup node-param dup +inlined+ depends-on - word-def splice-quot ; - -: method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 8 <= ] [ drop f ] if ; - -M: #call optimize-node* - { - { [ dup flush-eval? ] [ flush-eval ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup find-identity ] [ apply-identities ] } - { [ dup optimizer-hook ] [ optimize-hook ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ dup optimistic-inline? ] [ optimistic-inline ] } - { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } - } cond dup not ; diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor old mode 100644 new mode 100755 index 02df55216c..26c74b32b4 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -1,9 +1,60 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel inference.dataflow combinators sequences -namespaces math ; +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard ; IN: optimizer.control +! ! ! Loop detection + +! A LOOP +! +! #label A +! | +! #if ----> #merge ----> #return +! | +! ------------- +! | | +! #call-label A | +! | ... +! #values +! +! NOT A LOOP (call to A not in tail position): +! +! +! #label A +! | +! #if ----> ... ----> #merge ----> #return +! | +! ------------- +! | | +! #call-label A | +! | ... +! ... +! | +! #values +! +! NOT A LOOP (call to A nested inside another label/loop): +! +! +! #label A +! | +! #if ----> #merge ----> ... ----> #return +! | +! ------------- +! | | +! ... #label B +! | +! #if -> ... +! | +! --------- +! | | +! #call-label A | +! | | +! ... ... + GENERIC: detect-loops* ( node -- ) M: node detect-loops* drop ; @@ -34,3 +85,201 @@ M: #call-label detect-loops* : detect-loops ( node -- ) [ detect-loops* ] each-node ; + +! ! ! Constant branch folding +! +! BEFORE +! +! #if ----> #merge ----> C +! | +! --------- +! | | +! A B +! | | +! #values | +! #values +! +! AFTER +! +! | +! A +! | +! #values +! | +! #merge +! | +! C + +: fold-branch ( node branch# -- node ) + over node-children nth + swap node-successor over splice-node ; + +! #if +: known-boolean-value? ( node value -- value ? ) + 2dup node-literal? [ + node-literal t + ] [ + node-class { + { [ dup null class< ] [ drop f f ] } + { [ dup general-t class< ] [ drop t t ] } + { [ dup \ f class< ] [ drop f t ] } + { [ t ] [ drop f f ] } + } cond + ] if ; + +: fold-if-branch? dup node-in-d first known-boolean-value? ; + +: fold-if-branch ( node value -- node' ) + over drop-inputs >r + 0 1 ? fold-branch + r> [ set-node-successor ] keep ; + +! ! ! Lifting code after a conditional if one branch throws +: only-one ( seq -- elt/f ) + dup length 1 = [ first ] [ drop f ] if ; + +: lift-throw-tail? ( #if -- tail/? ) + dup node-successor #tail? + [ drop f ] [ active-children only-one ] if ; + +: clone-node ( node -- newnode ) + clone dup [ clone ] modify-values ; + +: detach-node-successor ( node -- successor ) + dup node-successor #terminate rot set-node-successor ; + +! BEFORE +! +! #if ----> #merge ----> B ----> #return/#values +! | +! | +! --------- +! | | +! | A +! #terminate | +! #values +! +! AFTER +! +! #if ----> #merge (*) ----> #return/#values (**) +! | +! | +! --------- +! | | +! | A +! #terminate | +! #values +! | +! #merge (***) +! | +! B +! | +! #return/#values +! +! (*) has the same outputs as the inputs of (**), and it is not +! the same node as (***) +! +! Note: if (**) is #return is is sound to put #terminate there, +! but not if (**) is #values + +: lift-branch + over + last-node clone-node + dup node-in-d \ #merge out-node + [ set-node-successor ] keep -rot + >r dup node-successor r> splice-node + set-node-successor ; + +M: #if optimize-node* + dup fold-if-branch? [ fold-if-branch t ] [ + drop dup lift-throw-tail? dup [ + dupd lift-branch t + ] [ + 2drop t f + ] if + ] if ; + +: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; + +: fold-dispatch-branch ( node value -- node' ) + dupd node-literal + over drop-inputs >r fold-branch r> + [ set-node-successor ] keep ; + +M: #dispatch optimize-node* + dup fold-dispatch-branch? [ + fold-dispatch-branch t + ] [ + 2drop t f + ] if ; + +! Loop tail hoising: code after a loop can sometimes go in the +! non-recursive branch of the loop + +! BEFORE: + +! #label -> C -> #return 1 +! | +! -> #if -> #merge -> #return 2 +! | +! -------- +! | | +! A B +! | | +! #values | +! #call-label +! | +! | +! #values + +! AFTER: + +! #label -> #terminate +! | +! -> #if -> #terminate +! | +! -------- +! | | +! A B +! | | +! #values | +! | #call-label +! #merge | +! | | +! C #values +! | +! #return 1 + +: find-final-if ( node -- #if/f ) + dup [ + dup #if? [ + dup node-successor #tail? [ + node-successor find-final-if + ] unless + ] [ + node-successor find-final-if + ] if + ] when ; + +: lift-loop-tail? ( #label -- tail/f ) + dup node-successor node-successor [ + dup node-param swap node-child find-final-if dup [ + node-children [ penultimate-node ] map + [ + dup #call-label? + [ node-param eq? not ] [ 2drop t ] if + ] with subset only-one + ] [ 2drop f ] if + ] [ drop f ] if ; + +! M: #loop optimize-node* +! dup lift-loop-tail? dup [ +! last-node >r +! dup detach-node-successor +! over node-child find-final-if detach-node-successor +! [ set-node-successor ] keep +! r> set-node-successor +! t +! ] [ +! 2drop t f +! ] if ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor new file mode 100755 index 0000000000..a272d05b5d --- /dev/null +++ b/core/optimizer/inlining/inlining.factor @@ -0,0 +1,227 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control ; +IN: optimizer.inlining + +GENERIC: remember-method* ( method-spec node -- ) + +M: #call remember-method* + [ node-history ?push ] keep set-node-history ; + +M: node remember-method* + 2drop ; + +: remember-method ( method-spec node -- ) + swap dup second +inlined+ depends-on + [ swap remember-method* ] curry each-node ; + +: (splice-method) ( #call method-spec quot -- node ) + #! Must remember the method before splicing in, otherwise + #! the rest of the IR will also remember the method + pick node-in-d dataflow-with + [ remember-method ] keep + [ swap infer-classes/node ] 2keep + [ splice-node ] keep ; + +: splice-quot ( #call quot -- node ) + over node-in-d dataflow-with + [ swap infer-classes/node ] 2keep + [ splice-node ] keep ; + +! #call +: splice-method ( #call method-spec/t quot/t -- node/t ) + #! t indicates failure + { + { [ dup t eq? ] [ 3drop t ] } + { [ 2over swap node-history member? ] [ 3drop t ] } + { [ t ] [ (splice-method) ] } + } cond ; + +! Single dispatch method inlining optimization +: already-inlined? ( node -- ? ) + #! Was this node inlined from definition of 'word'? + dup node-param swap node-history memq? ; + +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; + +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + dup get over inline? not or + [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + +: (flat-length) ( seq -- n ) + [ + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond + ] map sum ; + +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + +: will-inline-method ( node word -- method-spec/t quot/t ) + #! t indicates failure + tuck dispatching-class dup [ + swap [ 2array ] 2keep + method method-word + dup flat-length 10 >= + [ 1quotation ] [ word-def ] if + ] [ + 2drop t t + ] if ; + +: inline-standard-method ( node word -- node ) + dupd will-inline-method splice-method ; + +! Partial dispatch of math-generic words +: math-both-known? ( word left right -- ? ) + math-class-max swap specific-method ; + +: will-inline-math-method ( word left right -- method-spec/t quot/t ) + #! t indicates failure + 3dup math-both-known? + [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ; + +: inline-math-method ( #call word -- node ) + over node-input-classes first2 + will-inline-math-method splice-method ; + +: inline-method ( #call -- node ) + dup node-param { + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ t ] [ 2drop t ] } + } cond ; + +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class< >r classes-intersect? not r> or ; + +: optimize-predicate? ( #call -- ? ) + dup node-param "predicating" word-prop dup [ + >r node-class-first r> comparable? + ] [ + 2drop f + ] if ; + +: literal-quot ( node literals -- quot ) + #! Outputs a quotation which drops the node's inputs, and + #! pushes some literals. + >r node-in-d length \ drop + r> [ literalize ] map append >quotation ; + +: inline-literals ( node literals -- node ) + #! Make #shuffle -> #push -> #return -> successor + dupd literal-quot splice-quot ; + +: evaluate-predicate ( #call -- ? ) + dup node-param "predicating" word-prop >r + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + #! If the predicate is followed by a branch we fold it + #! immediately + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; + +: flush-eval? ( #call -- ? ) + dup node-param "flushable" word-prop [ + node-out-d [ unused? ] all? + ] [ + drop f + ] if ; + +: flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup node-out-d length f inline-literals ; + +: partial-eval? ( #call -- ? ) + dup node-param "foldable" word-prop [ + dup node-in-d [ node-literal? ] with all? + ] [ + drop f + ] if ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ node-literal ] with map ; + +: partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup literal-in-d over node-param 1quotation + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; + +: define-identities ( words identities -- ) + [ "identities" set-word-prop ] curry each ; + +: find-identity ( node -- quot ) + [ node-param "identities" word-prop ] keep + [ swap first in-d-match? ] curry find + nip dup [ second ] when ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ splice-quot ] [ 2drop f ] if ; + +: optimistic-inline? ( #call -- ? ) + dup node-param "specializer" word-prop dup [ + >r node-input-classes r> specialized-length tail* + [ types length 1 = ] all? + ] [ + 2drop f + ] if ; + +: optimistic-inline ( #call -- node ) + dup node-param dup +inlined+ depends-on + word-def splice-quot ; + +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 8 <= ] [ drop f ] if ; + +M: #call optimize-node* + { + { [ dup flush-eval? ] [ flush-eval ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity ] [ apply-identities ] } + { [ dup optimizer-hook ] [ optimize-hook ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } + { [ t ] [ inline-method ] } + } cond dup not ; diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 8534f1f090..d725396e77 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32 io.streams.string layouts splitting math.intervals math.floats.private tuples tuples.private classes optimizer.def-use optimizer.backend optimizer.pattern-match -float-arrays sequences.private combinators ; +optimizer.inlining float-arrays sequences.private combinators ; ! the output of and has the class which is ! its second-to-last input diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index e048e29f48..9bd1fe3250 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io namespaces assocs quotations math.intervals sequences.private combinators splitting layouts math.parser classes generic.math optimizer.pattern-match optimizer.backend optimizer.def-use -generic.standard system ; +optimizer.inlining generic.standard system ; { + bignum+ float+ fixnum+fast } { { { number 0 } [ drop ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 8f30abd09f..0984350c6b 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations growable ; +continuations growable optimizer.inlining ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index a699bb0cb3..9e898450cc 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use optimizer.known-words optimizer.math optimizer.control -inference.class ; +optimizer.inlining inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) From 803e49b129a1d4e7d642f0ceb4b93cedf11c8621 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Feb 2008 20:14:48 -0600 Subject: [PATCH 02/58] Add unit test and fix USING: --- core/optimizer/control/control.factor | 6 +++--- core/optimizer/optimizer-tests.factor | 12 ++++++++++++ 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index 26c74b32b4..de3aeb220a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -145,9 +145,6 @@ M: #call-label detect-loops* : clone-node ( node -- newnode ) clone dup [ clone ] modify-values ; -: detach-node-successor ( node -- successor ) - dup node-successor #terminate rot set-node-successor ; - ! BEFORE ! ! #if ----> #merge ----> B ----> #return/#values @@ -261,6 +258,9 @@ M: #dispatch optimize-node* ] if ] when ; +: detach-node-successor ( node -- successor ) + dup node-successor #terminate rot set-node-successor ; + : lift-loop-tail? ( #label -- tail/f ) dup node-successor node-successor [ dup node-param swap node-child find-final-if dup [ diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 0984350c6b..e5e0d9fe77 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -301,3 +301,15 @@ TUPLE: silly-tuple a b ; [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test + +! Regression +: lift-throw-tail-regression + dup integer? [ "an integer" ] [ + dup string? [ "a string" ] [ + "error" throw + ] if + ] if ; + +[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test +[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test From 2f5ad0324b0bea5d02d8ed6e13e55c63c65e8be3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 13 Feb 2008 23:21:04 -0600 Subject: [PATCH 03/58] io.utf8 renamed to io.encodings.utf8 --- core/io/encodings/utf8/utf8-docs.factor | 4 ++-- extra/http/http.factor | 2 +- extra/ui/x11/x11.factor | 12 ++++++------ extra/x11/clipboard/clipboard.factor | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) mode change 100644 => 100755 core/io/encodings/utf8/utf8-docs.factor mode change 100644 => 100755 extra/x11/clipboard/clipboard.factor diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor old mode 100644 new mode 100755 index 212552519c..6e1923824f --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -1,12 +1,12 @@ USING: help.markup help.syntax io.encodings strings ; IN: io.encodings.utf8 -ARTICLE: "io.utf8" "Working with UTF8-encoded data" +ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" "The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." { $subsection encode-utf8 } { $subsection decode-utf8 } ; -ABOUT: "io.utf8" +ABOUT: "io.encodings.utf8" HELP: decode-utf8 { $values { "seq" "a sequence of bytes" } { "str" string } } diff --git a/extra/http/http.factor b/extra/http/http.factor index 755f36a538..5c4dae94c7 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.utf8 assocs.lib +sequences strings splitting ascii io.encodings.utf8 assocs.lib namespaces unicode.case ; IN: http diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index e4794452c7..082a27317a 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend -ui.clipboards ui.gadgets.worlds assocs kernel math namespaces -opengl sequences strings x11.xlib x11.events x11.xim x11.glx -x11.clipboard x11.constants x11.windows io.utf8 combinators -debugger system command-line ui.render math.vectors tuples -opengl.gl threads ; +USING: alien alien.c-types arrays ui ui.gadgets ui.gestures +ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math +namespaces opengl sequences strings x11.xlib x11.events x11.xim +x11.glx x11.clipboard x11.constants x11.windows +io.encodings.utf8 combinators debugger system command-line +ui.render math.vectors tuples opengl.gl threads ; IN: ui.x11 TUPLE: x11-ui-backend ; diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor old mode 100644 new mode 100755 index 5978ee6f7f..eb4191ebb1 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays kernel math -namespaces sequences io.utf8 x11.xlib x11.constants ; +namespaces sequences io.encodings.utf8 x11.xlib x11.constants ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp From eca7c0b739ae778e22d54e8e8b537789b964285a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 00:43:50 -0600 Subject: [PATCH 04/58] builder: bit refactoring --- extra/builder/builder.factor | 101 ++++++++++----------------------- extra/builder/util/util.factor | 82 ++++++++++++++++++++++++++ 2 files changed, 112 insertions(+), 71 deletions(-) create mode 100644 extra/builder/util/util.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a3e925338f..eb5b6689b0 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -3,45 +3,25 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads arrays system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client combinators bootstrap.image bootstrap.image.download - combinators.cleave benchmark ; + combinators.cleave benchmark + classes strings quotations words parser-combinators new-slots accessors + assocs.lib smtp builder.util ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: runtime ( quot -- time ) benchmark nip ; - -: minutes>ms ( min -- ms ) 60 * 1000 * ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SYMBOL: builder-recipients -: host-name* ( -- name ) host-name "." split first ; +: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; -: tag-subject ( str -- str ) `{ "builder@" ,[ host-name* ] ": " , } concat ; - -: email-string ( subject -- ) - `{ "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } - [ ] with-process-stream drop ; - -: email-file ( subject file -- ) - `{ - { +stdin+ , } - { +arguments+ - { "mutt" "-s" ,[ tag-subject ] %[ builder-recipients get ] } } - } - >hashtable run-process drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } + { "winnt" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } case ; : git-pull ( -- desc ) @@ -57,14 +37,6 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: datestamp ( -- string ) - now `{ ,[ dup timestamp-year ] - ,[ dup timestamp-month ] - ,[ dup timestamp-day ] - ,[ dup timestamp-hour ] - ,[ timestamp-minute ] } - [ pad-00 ] map "-" join ; - VAR: stamp : enter-build-dir ( -- ) @@ -82,49 +54,31 @@ VAR: stamp : make-clean ( -- desc ) { "make" "clean" } ; -: make-vm ( -- ) - `{ - { +arguments+ { "make" ,[ target ] } } - { +stdout+ "../compile-log" } - { +stderr+ +stdout+ } - } - >hashtable ; +: make-vm ( -- desc ) + + { "make" target } to-strings >>arguments + "../compile-log" >>stdout + +stdout+ >>stderr + >desc ; + +: bootstrap-cmd ( -- cmd ) + { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" } + to-strings ; : bootstrap ( -- desc ) - `{ - { +arguments+ { - ,[ factor-binary ] - ,[ "-i=" my-boot-image-name append ] - "-no-user-init" - } } - { +stdout+ "../boot-log" } - { +stderr+ +stdout+ } - { +timeout+ ,[ 20 minutes>ms ] } - } ; + + bootstrap-cmd >>arguments + "../boot-log" >>stdout + +stdout+ >>stderr + 20 minutes>ms >>timeout + >desc ; -: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ; +: builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ; SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: milli-seconds>time ( n -- string ) - 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; - -: eval-file ( file -- obj ) contents eval ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: cat ( file -- ) contents print ; - -: run-or-bail ( desc quot -- ) - [ [ try-process ] curry ] - [ [ throw ] curry ] - bi* - recover ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : (build) ( -- ) enter-build-dir @@ -182,7 +136,12 @@ SYMBOL: build-status : build ( -- ) [ (build) ] [ drop ] recover - "report" "../report" email-file ; + + "ed@factorcode.org" >>from + builder-recipients get >>to + "report" tag-subject >>subject + "../report" file>string >>body + send ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor new file mode 100644 index 0000000000..9917cbd759 --- /dev/null +++ b/extra/builder/util/util.factor @@ -0,0 +1,82 @@ + +USING: kernel words namespaces classes parser continuations + io io.files io.launcher io.sockets + math math.parser + combinators sequences splitting quotations arrays strings tools.time + parser-combinators accessors assocs.lib + combinators.cleave bake calendar new-slots ; + +IN: builder.util + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: runtime ( quot -- time ) benchmark nip ; + +: minutes>ms ( min -- ms ) 60 * 1000 * ; + +: file>string ( file -- string ) [ stdio get contents ] with-file-in ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: to-strings + +: to-string ( obj -- str ) + dup class + { + { string [ ] } + { quotation [ call ] } + { word [ execute ] } + { fixnum [ number>string ] } + { array [ to-strings concat ] } + } + case ; + +: to-strings ( seq -- str ) + dup [ string? ] all? + [ ] + [ [ to-string ] map flatten ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: process* arguments stdout stderr timeout ; + +: process* construct-empty ; + +: >desc ( process* -- desc ) + H{ } clone + over arguments>> [ +arguments+ swap put-at ] when* + over stdout>> [ +stdout+ swap put-at ] when* + over stderr>> [ +stderr+ swap put-at ] when* + over timeout>> [ +timeout+ swap put-at ] when* + nip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: host-name* ( -- name ) host-name "." split first ; + +: datestamp ( -- string ) + now `{ ,[ dup timestamp-year ] + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } + [ pad-00 ] map "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: milli-seconds>time ( n -- string ) + 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; + +: eval-file ( file -- obj ) contents eval ; + +: cat ( file -- ) contents print ; + +: run-or-bail ( desc quot -- ) + [ [ try-process ] curry ] + [ [ throw ] curry ] + bi* + recover ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 0cc1c0d5972d2a0ba3be8140ca06f70e24e59d4c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 00:44:09 -0600 Subject: [PATCH 05/58] smtp: Use email object --- extra/smtp/smtp.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 27aac1202e..ce5c114c00 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -169,3 +169,15 @@ LOG: smtp-response DEBUG ! : cram-md5-auth ( key login -- ) ! "AUTH CRAM-MD5\r\n" get-ok ! (cram-md5-auth) "\r\n" append get-ok ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: new-slots + +TUPLE: email from to subject body ; + +: ( -- email ) email construct-empty ; + +: send ( email -- ) + { email-body email-subject email-to email-from } get-slots + send-simple-message ; \ No newline at end of file From a8cd31311dfb0ca37244c52a95bfa5b15eb71531 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 01:01:09 -0600 Subject: [PATCH 06/58] builder: more tweaks --- extra/builder/builder.factor | 52 ++++++++++++++++-------------- extra/builder/server/server.factor | 46 +++++++++++++------------- 2 files changed, 51 insertions(+), 47 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index eb5b6689b0..1e1cc2778f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -11,28 +11,6 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: builder-recipients - -: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; - -: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; - -: factor-binary ( -- name ) - os - { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "winnt" [ "./factor-nt.exe" ] } - [ drop "./factor" ] } - case ; - -: git-pull ( -- desc ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; - : git-clone ( -- desc ) { "git" "clone" "../factor" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -54,6 +32,10 @@ VAR: stamp : make-clean ( -- desc ) { "make" "clean" } ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; + : make-vm ( -- desc ) { "make" target } to-strings >>arguments @@ -61,6 +43,15 @@ VAR: stamp +stdout+ >>stderr >desc ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: factor-binary ( -- name ) + os + { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } + { "winnt" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } + case ; + : bootstrap-cmd ( -- cmd ) { factor-binary [ "-i=" my-boot-image-name append ] "-no-user-init" } to-strings ; @@ -75,8 +66,6 @@ VAR: stamp : builder-test ( -- desc ) { factor-binary "-run=builder.test" } to-strings ; -SYMBOL: build-status - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (build) ( -- ) @@ -134,6 +123,12 @@ SYMBOL: build-status ] with-file-out ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-recipients + +: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; + : build ( -- ) [ (build) ] [ drop ] recover @@ -145,6 +140,15 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: git-pull ( -- desc ) + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } ; + : updates-available? ( -- ? ) git-id git-pull run-process drop diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor index 672de1e47d..f3ec349557 100644 --- a/extra/builder/server/server.factor +++ b/extra/builder/server/server.factor @@ -41,28 +41,28 @@ IN: builder.server ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: build-server ( -- ) - receive - { - { - "start" - [ - build-status get "idle" = - build-status get f = - or - [ - [ [ build ] [ drop ] recover "idle" build-status set-global ] - in-thread - ] - when - ] - } +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! build-status get "idle" = +! build-status get f = +! or +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] +! in-thread +! ] +! when +! ] +! } - { - { ?from ?tag "status" } - [ `{ ?tag ,[ build-status get ] } ?from send ] - } - } - match-cond - build-server ; +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; From 2c73e72e5ea46fa688cafda74358c7fe45d58b10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:03:57 -0600 Subject: [PATCH 07/58] case now optimizes contiguous integer ranges --- core/combinators/combinators-docs.factor | 22 +++------ core/combinators/combinators-tests.factor | 7 +++ core/combinators/combinators.factor | 55 ++++++++++++++++++--- core/hashtables/hashtables.factor | 18 ++----- core/inference/transforms/transforms.factor | 2 +- 5 files changed, 68 insertions(+), 36 deletions(-) mode change 100644 => 100755 core/combinators/combinators-tests.factor diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index d91c920def..5b87297b0c 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -7,11 +7,7 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" { $subsection cond>quot } { $subsection case>quot } -{ $subsection alist>quot } -"A powerful tool used to optimize code in several places is open-coded hashtable dispatch:" -{ $subsection hash-case>quot } -{ $subsection distribute-buckets } -{ $subsection hash-dispatch-quot } ; +{ $subsection alist>quot } ; ARTICLE: "combinators" "Additional combinators" "The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":" @@ -104,19 +100,17 @@ HELP: case>quot { $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } } { $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." $nl -"The quotation actually tests each possible case in order;" { $link hash-case>quot } " produces more efficient code." } ; +"This word uses three strategies:" +{ $list + "If the assoc only has a few keys, a linear search is generated." + { "If the assoc has a large number of keys which form a contiguous range of integers, a direct dispatch is generated using the " { $link dispatch } " word together with a bounds check." } + "Otherwise, an open-coded hashtable dispatch is generated." +} } ; HELP: distribute-buckets { $values { "assoc" "an alist" } { "initial" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- assoc )" } } { "buckets" "a new array" } } { $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." } -{ $notes "This word is used in the implemention of " { $link hash-case>quot } " and " { $link standard-combination } "." } ; - -HELP: hash-case>quot -{ $values { "default" quotation } { "assoc" "an association list mapping quotations to quotations" } { "quot" quotation } } -{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "." -$nl -"The quotation uses an efficient hash-based search to avoid testing the object against all possible keys." } -{ $notes "This word is used behind the scenes to compile " { $link case } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ; +{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ; HELP: dispatch ( n array -- ) { $values { "n" "a fixnum" } { "array" "an array of quotations" } } diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 index 3cefda7f71..ce8e180867 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -69,3 +69,10 @@ namespaces combinators words ; ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test + +[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test +[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test +[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test +[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test +[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test +[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0ba8b583be..ffd1576e6e 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: combinators USING: arrays sequences sequences.private math.private -kernel kernel.private math assocs quotations vectors ; +kernel kernel.private math assocs quotations vectors +hashtables sorting ; TUPLE: no-cond ; @@ -31,16 +32,24 @@ TUPLE: no-case ; : recursive-hashcode ( n obj quot -- code ) pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline +! These go here, not in sequences and hashtables, since those +! two depend on combinators M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ; +M: hashtable hashcode* + [ + dup assoc-size 1 number= + [ assoc-hashcode ] [ nip assoc-size ] if + ] recursive-hashcode ; + : alist>quot ( default assoc -- quot ) [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) reverse [ no-cond ] swap alist>quot ; -: case>quot ( default assoc -- quot ) +: linear-case-quot ( default assoc -- quot ) [ >r [ dupd = ] curry r> \ drop add* ] assoc-map alist>quot ; @@ -63,20 +72,50 @@ M: sequence hashcode* : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets - [ case>quot ] with map ; + [ linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) [ length 1- [ fixnum-bitand ] curry ] keep [ dispatch ] curry append ; -: hash-case>quot ( default assoc -- quot ) +: hash-case-quot ( default assoc -- quot ) + hash-case-table hash-dispatch-quot + [ dup hashcode >fixnum ] swap append ; + +: contiguous-range? ( keys -- from to ? ) + dup [ fixnum? ] all? [ + dup all-unique? [ + dup infimum over supremum + [ - swap prune length + 1 = ] 2keep rot + ] [ + drop f f f + ] if + ] [ + drop f f f + ] if ; + +: dispatch-case ( value from to default array -- ) + >r >r 3dup between? [ + drop - >fixnum r> drop r> dispatch + ] [ + 2drop r> call r> drop + ] if ; inline + +: dispatch-case-quot ( default assoc from to -- quot ) + -roll -roll sort-keys values [ >quotation ] map + [ dispatch-case ] 2curry 2curry ; + +: case>quot ( default assoc -- quot ) dup empty? [ drop ] [ dup length 4 <= [ - case>quot + linear-case-quot ] [ - hash-case-table hash-dispatch-quot - [ dup hashcode >fixnum ] swap append + dup keys contiguous-range? [ + dispatch-case-quot + ] [ + 2drop hash-case-quot + ] if ] if ] if ; diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index b24928a71e..8c935db859 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors -combinators ; +math.private sequences sequences.private vectors ; IN: hashtables ; diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 7faeefc3d6..240f39218b 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -35,7 +35,7 @@ IN: inference.transforms dup peek swap 1 head* ] [ [ no-case ] swap - ] if hash-case>quot + ] if case>quot ] if ] 1 define-transform From 0bbb462fa623c7125083931c04dcd7b9fdea5027 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:04:10 -0600 Subject: [PATCH 08/58] Add unit test --- core/optimizer/optimizer-tests.factor | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index e5e0d9fe77..6a76892246 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -313,3 +313,19 @@ TUPLE: silly-tuple a b ; [ t ] [ \ lift-throw-tail-regression compiled? ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test + +: lift-loop-tail-test-1 ( a quot -- ) + over even? [ + [ >r 3 - r> call ] keep lift-loop-tail-test-1 + ] [ + over 0 < [ + 2drop + ] [ + [ >r 2 - r> call ] keep lift-loop-tail-test-1 + ] if + ] if ; inline + +: lift-loop-tail-test-2 + 10 [ ] lift-loop-tail-test-1 1 2 3 ; + +[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test From ce59673c12852f2aa458be48e4b7b3210615b235 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:04:16 -0600 Subject: [PATCH 09/58] Fix load errors --- core/io/encodings/latin1/latin1.factor | 2 +- core/io/encodings/utf16/utf16.factor | 12 ++++-------- 2 files changed, 5 insertions(+), 9 deletions(-) mode change 100644 => 100755 core/io/encodings/latin1/latin1.factor diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor old mode 100644 new mode 100755 index 2c2aa8d60a..468324316d --- a/core/io/encodings/latin1/latin1.factor +++ b/core/io/encodings/latin1/latin1.factor @@ -1,4 +1,4 @@ -USING: io.encodings strings kernel ; +USING: io io.encodings strings kernel ; IN: io.encodings.latin1 TUPLE: latin1 stream ; diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index 99e98cd98c..84017324ee 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary io.encodings combinators splitting ; -IN: io.utf16 +IN: io.encodings.utf16 SYMBOL: double SYMBOL: quad1 @@ -104,14 +104,10 @@ SYMBOL: ignore : encode-utf16 ( str -- seq ) encode-utf16le bom-le swap append ; -: utf16le? ( seq1 -- seq2 ? ) bom-le ?head ; - -: utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; - : decode-utf16 ( seq -- str ) { - { [ utf16le? ] [ decode-utf16le ] } - { [ utf16be? ] [ decode-utf16be ] } + { [ bom-le ?head ] [ decode-utf16le ] } + { [ bom-be ?head ] [ decode-utf16be ] } { [ t ] [ decode-error ] } } cond ; @@ -127,4 +123,4 @@ TUPLE: utf16be ; INSTANCE: utf16be encoding-stream M: utf16be encode-string drop encode-utf16be ; -M: utf16le decode-step drop decode-utf16be-step ; +M: utf16be decode-step drop decode-utf16be-step ; From 939d5bdbb0344aba998002fa0b869e58880ae8a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:06:27 -0600 Subject: [PATCH 10/58] Use case instead of dispatch --- extra/icfp/2006/2006.factor | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 2a35ed08f8..ae0e058490 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Gavin Harrison ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences kernel.private namespaces arrays io io.files - splitting io.binary math.functions vectors quotations sequences.private ; +USING: kernel math sequences kernel.private namespaces arrays io +io.files splitting io.binary math.functions vectors quotations +combinators ; IN: icfp.2006 SYMBOL: regs @@ -9,10 +10,6 @@ SYMBOL: arrays SYMBOL: finger SYMBOL: open-arrays -: call-nth ( n array -- ) - >r >fixnum r> 2dup nth quotation? - [ dispatch ] [ "Not a quotation" throw ] if ; inline - : reg-val ( m -- n ) regs get nth ; : set-reg ( val n -- ) regs get set-nth ; @@ -117,11 +114,21 @@ SYMBOL: open-arrays : run-op ( -- bool ) advance { - [ op0 ] [ op1 ] [ op2 ] [ op3 ] - [ op4 ] [ op5 ] [ op6 ] [ drop t ] - [ op8 ] [ op9 ] [ op10 ] [ op11 ] - [ op12 ] [ op13 ] - } call-nth ; + { 0 [ op0 ] } + { 1 [ op1 ] } + { 2 [ op2 ] } + { 3 [ op3 ] } + { 4 [ op4 ] } + { 5 [ op5 ] } + { 6 [ op6 ] } + { 7 [ drop t ] } + { 8 [ op8 ] } + { 9 [ op9 ] } + { 10 [ op10 ] } + { 11 [ op11 ] } + { 12 [ op12 ] } + { 13 [ op13 ] } + } case ; : exec-loop ( bool -- ) [ run-op exec-loop ] unless ; From cdbd0a4c05b115c22321ba71018037ed0e26fc0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:06:46 -0600 Subject: [PATCH 11/58] Fix load error --- extra/math/analysis/analysis.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/math/analysis/analysis.factor diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor old mode 100644 new mode 100755 index a41281d779..0b4b14ce54 --- a/extra/math/analysis/analysis.factor +++ b/extra/math/analysis/analysis.factor @@ -1,5 +1,5 @@ USING: kernel math math.constants math.functions math.intervals -math.vectors namespaces sequences ; +math.vectors namespaces sequences combinators.cleave ; IN: math.analysis Date: Thu, 14 Feb 2008 01:07:00 -0600 Subject: [PATCH 12/58] load-everything now reports errors --- extra/tools/browser/browser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index b6c0ef3ecc..75ae377ea7 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -132,7 +132,7 @@ MEMO: all-vocabs-seq ( -- seq ) require-all ; : load-everything ( -- ) - try-everything drop ; + try-everything load-failures. ; : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless From ddd2c5b5e7ab6f1df5269ec9aad51f64468dd865 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 01:07:18 -0600 Subject: [PATCH 13/58] builder.test: fix using --- extra/builder/test/test.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index c18395acc9..7412dd9b36 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations prettyprint tools.browser tools.test - bootstrap.stage2 benchmark ; + bootstrap.stage2 benchmark builder.util ; IN: builder.test From 2e1e38db890887ed31917ed7b5474b7252e23f60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 01:17:54 -0600 Subject: [PATCH 14/58] Fix +timeout+ --- extra/io/launcher/launcher.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index cbece818c9..6e6d79d8a4 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -119,7 +119,9 @@ HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; : ( desc -- stream ) - >descriptor process-stream* + >descriptor + [ process-stream* ] keep + +timeout+ swap at [ over set-timeout ] when* { set-delegate set-process-stream-process } process-stream construct ; From 86667aee238c9e710ffad94dbd1393474d9ff627 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Feb 2008 01:27:54 -0600 Subject: [PATCH 15/58] execute-statement is now a word not a generic sqlite works for tuple-tests postgresql create/drop/insert works better now --- extra/db/db.factor | 22 ++- extra/db/postgresql/lib/lib.factor | 11 +- extra/db/postgresql/postgresql-tests.factor | 6 +- extra/db/postgresql/postgresql.factor | 141 ++++++++++++++------ extra/db/sqlite/lib/lib.factor | 3 +- extra/db/sqlite/sqlite.factor | 9 +- extra/db/tuples/tuples-tests.factor | 12 +- extra/db/tuples/tuples.factor | 6 +- extra/db/types/types.factor | 1 + 9 files changed, 130 insertions(+), 81 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 46b257ce7a..365f0c009c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -36,13 +36,17 @@ HOOK: db ( str -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) -GENERIC: execute-statement* ( statement -- result-set ) +GENERIC: insert-statement ( statement -- id ) HOOK: last-id db ( res -- id ) -: execute-statement ( statement -- ) - execute-statement* dispose ; -: execute-statement-last-id ( statement -- id ) - execute-statement* [ last-id ] with-disposal ; +TUPLE: result-set sql params handle n max ; +GENERIC: query-results ( query -- result-set ) +GENERIC: #rows ( result-set -- n ) +GENERIC: #columns ( result-set -- n ) +GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC: advance-row ( result-set -- ? ) + +: execute-statement ( statement -- ) query-results dispose ; : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when @@ -50,14 +54,6 @@ HOOK: last-id db ( res -- id ) [ set-statement-params ] keep t swap set-statement-bound? ; -TUPLE: result-set sql params handle n max ; - -GENERIC: query-results ( query -- result-set ) -GENERIC: #rows ( result-set -- n ) -GENERIC: #columns ( result-set -- n ) -GENERIC# row-column 1 ( result-set n -- obj ) -GENERIC: advance-row ( result-set -- ? ) - : init-result-set ( result-set -- ) dup #rows over set-result-set-max -1 swap set-result-set-n ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index d8381ca83a..c48eff964a 100644 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces -quotations sequences db.postgresql.ffi alien alien.c-types ; +quotations sequences db.postgresql.ffi alien alien.c-types +db.types ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -37,13 +38,9 @@ IN: db.postgresql.lib >r db get db-handle r> [ statement-sql ] keep [ statement-params length f ] keep - statement-params [ second malloc-char-string ] map >c-void*-array + statement-params + [ first number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw ] unless ; - -: pq-oid-value ( res -- n ) - PQoidValue dup InvalidOid = [ - "postgresql returned an InvalidOid" throw - ] when ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 8c6791c767..36b6fc829b 100644 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -2,7 +2,7 @@ ! Set username and password in the 'connect' word. USING: kernel db.postgresql alien continuations io prettyprint -sequences namespaces tools.test db ; +sequences namespaces tools.test db db.types ; IN: temporary IN: scratchpad @@ -40,13 +40,13 @@ IN: temporary test-db [ "select * from person where name = $1 and country = $2" [ - { "Jane" "New Zealand" } + { { "Jane" TEXT } { "New Zealand" TEXT } } over do-bound-query { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless - { "John" "America" } + { { "John" TEXT } { "America" TEXT } } swap do-bound-query ] with-disposal ] with-db diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index dac4d78b78..93c66708b4 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -3,7 +3,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi -db.tuples db.types ; +db.tuples db.types tools.annotations ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -52,8 +52,11 @@ M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set row-column ( result-set n -- obj ) >r dup result-set-handle swap result-set-n r> PQgetvalue ; -M: postgresql-statement execute-statement* ( statement -- obj ) - query-results ; +M: postgresql-statement execute-statement ( statement -- obj ) + query-results dispose ; + +M: postgresql-statement insert-statement ( statement -- id ) + query-results dispose ; : increment-n ( result-set -- n ) dup result-set-n 1+ dup rot set-result-set-n ; @@ -105,72 +108,137 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; +SYMBOL: postgresql-counter + +: make-postgresql-counter ( quot -- ) + [ postgresql-counter off ] swap compose "" make ; + +: counter% ( -- ) + CHAR: $ , + postgresql-counter [ inc ] keep get # ; + +: postgresql-type-hash* ( -- assoc ) + H{ + { SERIAL "serial" } + } ; + +: postgresql-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { SERIAL "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { DOUBLE "real" } + } ; + +: enquote ( str -- newstr ) "(" swap ")" 3append ; + +: postgresql-type ( str n/str -- newstr ) + " " swap number>string* enquote 3append ; + +: >sql-type* ( obj -- str ) + dup pair? [ + first2 >r >sql-type* r> postgresql-type + ] [ + dup postgresql-type-hash* at* [ + nip + ] [ + drop >sql-type + ] if + ] if ; + +M: postgresql-db >sql-type ( hash obj -- str ) + dup pair? [ + first2 >r >sql-type r> postgresql-type + ] [ + postgresql-type-hash at* [ + no-sql-type + ] unless + ] if ; M: postgresql-db create-sql ( columns table -- sql ) [ + 2dup "create table " % % " (" % [ ", " % ] [ dup second % " " % - dup third >sql-type % " " % + dup third >sql-type* % " " % sql-modifiers " " join % - ] interleave ")" % - ] "" make ; + ] interleave "); " % -M: postgresql-db drop-sql ( table -- sql ) - [ - "drop table " % % - ] "" make ; + "create function add_" % dup % + "(" % + over [ "," % ] + [ third dup array? [ first ] when >sql-type % ] interleave + ")" % + " returns bigint as '" % -SYMBOL: postgresql-counter - -M: postgresql-db insert-sql* ( columns table -- sql ) - [ - postgresql-counter off - "insert into " % + 2dup "insert into " % % "(" % dup [ ", " % ] [ second % ] interleave ") " % " values (" % - [ ", " % ] [ - drop "$" % postgresql-counter [ inc ] keep get # - ] interleave + [ ", " % ] [ drop counter% ] interleave + "); " % + + "select currval(''" % % "_id_seq'');' language sql;" % + drop + ] make-postgresql-counter dup . ; + +M: postgresql-db drop-sql ( columns table -- sql ) + [ + dup "drop table " % % + "; drop function add_" % % + "(" % + [ "," % ] [ third >sql-type % ] interleave ")" % + ] "" make ; +! \ create-sql reset +! \ create-sql watch + +M: postgresql-db insert-sql* ( columns table -- sql ) + [ + "select add_" % % + "(" % + [ ", " % ] [ counter% ] interleave + ")" % + ] make-postgresql-counter ; + M: postgresql-db update-sql* ( columns table -- sql ) [ "update " % % " set " % dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + [ ", " % ] [ second % " = " % counter% ] interleave " where " % - [ primary-key? ] find nip second dup % " = :" % % - ] "" make ; + [ primary-key? ] find nip second dup % " = " % counter% + ] make-postgresql-counter ; M: postgresql-db delete-sql* ( columns table -- sql ) [ "delete from " % % " where " % - first second dup % " = :" % % - ] "" make ; + first second dup % " = " % counter% + ] make-postgresql-counter ; M: postgresql-db select-sql* ( columns table -- sql ) drop ; M: postgresql-db tuple>params ( columns tuple -- obj ) - [ - >r dup first r> get-slot-named swap third - ] curry { } map>assoc ; + [ >r dup third swap first r> get-slot-named swap ] + curry { } map>assoc ; M: postgresql-db last-id ( res -- id ) - pq-oid-value ; + drop f ; : postgresql-db-modifiers ( -- hashtable ) H{ - { +native-id+ "primary key" } + { +native-id+ "not null primary key" } { +assigned-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } @@ -189,18 +257,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str ) swap at ] if ] with map [ ] subset ; - -: postgresql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "text" } - { DOUBLE "real" } - } ; - -M: postgresql-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - postgresql-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e97dcf80c9..2c0f2ae130 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -74,10 +74,11 @@ IN: db.sqlite.lib dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int-by-name ] } + { BIG_INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } + { SERIAL [ sqlite-bind-int-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index f58c669681..d83642bd8c 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -58,8 +58,8 @@ M: sqlite-statement bind-statement* ( triples statement -- ) M: sqlite-statement reset-statement ( statement -- ) statement-handle sqlite-reset ; -M: sqlite-statement execute-statement* ( statement -- obj ) - query-results ; +M: sqlite-statement insert-statement ( statement -- id ) + query-results [ last-id ] with-disposal ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql ) ] interleave ")" % ] "" make ; -M: sqlite-db drop-sql ( table -- sql ) +M: sqlite-db drop-sql ( columns table -- sql ) [ "drop table " % % + drop ] "" make ; M: sqlite-db insert-sql* ( columns table -- sql ) @@ -175,6 +176,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str ) : sqlite-type-hash ( -- assoc ) H{ { INTEGER "integer" } + { SERIAL "integer" } { TEXT "text" } { VARCHAR "text" } { DOUBLE "real" } @@ -190,4 +192,3 @@ M: sqlite-db >sql-type ( obj -- str ) ! HOOK: get-column-value ( n result-set type -- ) ! M: sqlite get-column-value { { "TEXT" get-text-column } { ! "INTEGER" get-integer-column } ... } case ; - diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6945ccc722..cb4129965c 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.sqlite db.tuples -db.types continuations namespaces db.postgresql math -tools.time ; +db.types continuations namespaces db.postgresql math ; +! tools.time ; IN: temporary TUPLE: person the-id the-name the-number real ; @@ -44,7 +44,7 @@ SYMBOL: the-person person "PERSON" { - { "the-id" "ROWID" INTEGER +native-id+ } + { "the-id" "ID" SERIAL +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -52,12 +52,12 @@ person "PERSON" "billy" 10 3.14 the-person set -test-sqlite + test-sqlite ! test-postgresql person "PERSON" { - { "the-id" "ROWID" INTEGER +assigned-id+ } + { "the-id" "ID" INTEGER +assigned-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -65,5 +65,5 @@ person "PERSON" 1 "billy" 20 6.28 the-person set -test-sqlite + test-sqlite ! test-postgresql diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 783001f3f8..1697de83d3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -39,7 +39,7 @@ TUPLE: no-slot-named ; [ ] 3compose cache nip ; inline HOOK: create-sql db ( columns table -- sql ) -HOOK: drop-sql db ( table -- sql ) +HOOK: drop-sql db ( columns table -- sql ) HOOK: insert-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) @@ -75,12 +75,12 @@ HOOK: tuple>params db ( columns tuple -- obj ) dup db-columns swap db-table create-sql sql-command ; : drop-table ( class -- ) - db-table drop-sql sql-command ; + dup db-columns swap db-table drop-sql sql-command ; : insert-tuple ( tuple -- ) [ [ maybe-remove-id ] [ insert-sql ] - make-tuple-statement execute-statement-last-id + make-tuple-statement insert-statement ] keep set-primary-key ; : update-tuple ( tuple -- ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b8c82524a8..30c15682fa 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -22,6 +22,7 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ +SYMBOL: SERIAL SYMBOL: INTEGER SYMBOL: DOUBLE SYMBOL: BOOLEAN From ce076166fec6785e5dfaeb84cb3603e2fb9cf31e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 02:20:20 -0600 Subject: [PATCH 16/58] Fix +closed+ --- extra/io/unix/launcher/launcher.factor | 9 +-- extra/io/windows/launcher/launcher.factor | 65 +++---------------- extra/io/windows/nt/launcher/launcher.factor | 66 ++++++++++++++++++-- extra/io/windows/{ => nt}/pipes/authors.txt | 0 extra/io/windows/{ => nt}/pipes/pipes.factor | 24 ++++++- 5 files changed, 96 insertions(+), 68 deletions(-) rename extra/io/windows/{ => nt}/pipes/authors.txt (100%) rename extra/io/windows/{ => nt}/pipes/pipes.factor (74%) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index c0861788b6..c14b11029b 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -50,15 +50,16 @@ MEMO: 'arguments' ( -- parser ) : redirect ( obj mode fd -- ) { { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] } - { [ pick +closed+ eq? ] [ close 2drop ] } { [ pick string? ] [ (redirect) ] } } cond ; +: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; + : setup-redirection ( -- ) - +stdin+ get read-flags 0 redirect - +stdout+ get write-flags 1 redirect + +stdin+ get ?closed read-flags 0 redirect + +stdout+ get ?closed write-flags 1 redirect +stderr+ get dup +stdout+ eq? - [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ; + [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ; : spawn-process ( -- ) [ diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f3f78fbb88..475a4ddef6 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io -io.windows io.windows.pipes libc io.nonblocking +io.windows io.windows.nt.pipes libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init strings combinators io.backend ; @@ -87,75 +87,26 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; -: (redirect) ( path access-mode create-mode -- handle ) - >r >r - normalize-pathname - r> ! access-mode - share-mode - security-attributes-inherit - r> ! create-mode - FILE_ATTRIBUTE_NORMAL ! flags and attributes - f ! template file - CreateFile dup invalid-handle? dup close-later ; - -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ 3drop t ] } - { [ pick string? ] [ (redirect) ] } - } cond ; - -: ?closed or dup t eq? [ drop f ] when ; - -: inherited-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdout ( args -- handle ) - +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stdout ?closed ; - -: inherited-stderr ( args -- handle ) - drop STD_ERROR_HANDLE GetStdHandle ; - -: redirect-stderr ( args -- handle ) - +stderr+ get - dup +stdout+ eq? [ - drop - CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput - ] [ - GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed - ] if ; - -: inherited-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe - [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdin ( args -- handle ) - +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin ?closed ; - : fill-startup-info dup CreateProcess-args-lpStartupInfo - STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags + STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ; - over redirect-stdout over set-STARTUPINFO-hStdOutput - over redirect-stderr over set-STARTUPINFO-hStdError - over redirect-stdin over set-STARTUPINFO-hStdInput +HOOK: fill-redirection io-backend ( args -- args ) - drop ; +M: windows-ce-io fill-redirection ; : make-CreateProcess-args ( -- args ) default-CreateProcess-args wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if fill-dwCreateFlags - fill-lpEnvironment ; + fill-lpEnvironment + fill-startup-info ; M: windows-io run-process* ( desc -- handle ) [ [ - make-CreateProcess-args fill-startup-info + make-CreateProcess-args + fill-redirection dup call-CreateProcess CreateProcess-args-lpProcessInformation ] with-descriptor diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index c2f14c21bb..cd9bb9baef 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -3,13 +3,63 @@ USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel -sequences windows.errors assocs splitting system -io.windows.launcher io.windows.pipes ; +sequences windows.errors assocs splitting system strings +io.windows.launcher io.windows.nt.pipes io.backend +combinators ; IN: io.windows.nt.launcher ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx +: (redirect) ( path access-mode create-mode -- handle ) + >r >r + normalize-pathname + r> ! access-mode + share-mode + security-attributes-inherit + r> ! create-mode + FILE_ATTRIBUTE_NORMAL ! flags and attributes + f ! template file + CreateFile dup invalid-handle? dup close-later ; + +: redirect ( obj access-mode create-mode -- handle ) + { + { [ pick not ] [ 3drop f ] } + { [ pick +closed+ eq? ] [ drop nip null-pipe ] } + { [ pick string? ] [ (redirect) ] } + } cond ; + +: ?closed or dup t eq? [ drop f ] when ; + +: inherited-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe + [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; + +: redirect-stdout ( args -- handle ) + +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stdout ?closed ; + +: inherited-stderr ( args -- handle ) + drop STD_ERROR_HANDLE GetStdHandle ; + +: redirect-stderr ( args -- handle ) + +stderr+ get + dup +stdout+ eq? [ + drop + CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput + ] [ + GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr ?closed + ] if ; + +: inherited-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe + [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; + +: redirect-stdin ( args -- handle ) + +stdin+ get GENERIC_READ OPEN_EXISTING redirect + swap inherited-stdin ?closed ; + : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; @@ -30,14 +80,22 @@ IN: io.windows.nt.launcher dup pipe-out f set-inherit over set-CreateProcess-args-stdin-pipe ; -M: windows-io process-stream* +M: windows-nt-io fill-redirection + dup CreateProcess-args-lpStartupInfo + over redirect-stdout over set-STARTUPINFO-hStdOutput + over redirect-stderr over set-STARTUPINFO-hStdError + over redirect-stdin over set-STARTUPINFO-hStdInput + drop ; + +M: windows-nt-io process-stream* [ [ make-CreateProcess-args fill-stdout-pipe fill-stdin-pipe - fill-startup-info + + fill-redirection dup call-CreateProcess diff --git a/extra/io/windows/pipes/authors.txt b/extra/io/windows/nt/pipes/authors.txt similarity index 100% rename from extra/io/windows/pipes/authors.txt rename to extra/io/windows/nt/pipes/authors.txt diff --git a/extra/io/windows/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor similarity index 74% rename from extra/io/windows/pipes/pipes.factor rename to extra/io/windows/nt/pipes/pipes.factor index 8c2acc4009..9591063609 100755 --- a/extra/io/windows/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.windows libc windows.types math windows.kernel32 windows namespaces kernel -sequences windows.errors assocs math.parser system random ; -IN: io.windows.pipes +sequences windows.errors assocs math.parser system random +combinators ; +IN: io.windows.nt.pipes ! This code is based on ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py @@ -65,3 +66,20 @@ TUPLE: pipe in out ; : ( -- pipe ) unique-pipe-name ; + +! /dev/null simulation +: null-input ( -- pipe ) + + dup pipe-out CloseHandle drop + pipe-in ; + +: null-output ( -- pipe ) + + dup pipe-in CloseHandle drop + pipe-out ; + +: null-pipe ( mode -- pipe ) + { + { [ dup GENERIC_READ = ] [ drop null-input ] } + { [ dup GENERIC_WRITE = ] [ drop null-output ] } + } cond ; From 5adf72b81d4fd0baa9b06d87463b9eccab7e4309 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 02:20:32 -0600 Subject: [PATCH 17/58] Fix header/body separation --- extra/smtp/server/server.factor | 4 +++- extra/smtp/smtp.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index 275deee994..3ca1c72296 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -29,6 +29,7 @@ USING: combinators kernel prettyprint io io.timeouts io.server sequences namespaces io.sockets continuations ; +IN: smtp.server SYMBOL: data-mode @@ -55,7 +56,7 @@ SYMBOL: data-mode data-mode off "220 OK\r\n" write flush t ] } - { [ data-mode get ] [ t ] } + { [ data-mode get ] [ global [ print ] bind t ] } { [ t ] [ "500 ERROR\r\n" write flush t ] } @@ -68,5 +69,6 @@ SYMBOL: data-mode 60000 stdio get set-timeout "220 hello\r\n" write flush process + global [ flush ] bind ] with-stream ] with-disposal ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 27aac1202e..26a23a265d 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -139,7 +139,7 @@ LOG: smtp-response DEBUG : prepare-message ( body headers -- body' ) [ prepare-headers - " " , + "" , dup string? [ string-lines ] when % ] { } make ; From 3b23cafefd83b26d11a999b5bfa19ea93c16833a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 05:20:38 -0600 Subject: [PATCH 18/58] builder: fix bug in run-or-bail --- extra/builder/builder.factor | 19 ++----------------- extra/builder/util/util.factor | 7 ++++--- 2 files changed, 6 insertions(+), 20 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 1e1cc2778f..00e39be2ba 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -59,6 +59,7 @@ VAR: stamp : bootstrap ( -- desc ) bootstrap-cmd >>arguments + +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr 20 minutes>ms >>timeout @@ -89,24 +90,8 @@ VAR: stamp [ my-arch download-image ] [ "Image download error" print throw ] recover - ! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail -! bootstrap -! dup dispose process-stream-process wait-for-process -! zero? not -! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ] -! when - - [ - bootstrap - dup dispose process-stream-process wait-for-process - zero? not - [ "bootstrap non-zero" throw ] - when - ] - [ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ] - recover - [ builder-test try-process ] [ "Builder test error" print throw ] recover diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 9917cbd759..b3b88874b0 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -39,13 +39,14 @@ DEFER: to-strings ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: process* arguments stdout stderr timeout ; +TUPLE: process* arguments stdin stdout stderr timeout ; : process* construct-empty ; : >desc ( process* -- desc ) H{ } clone over arguments>> [ +arguments+ swap put-at ] when* + over stdin>> [ +stdin+ swap put-at ] when* over stdout>> [ +stdout+ swap put-at ] when* over stderr>> [ +stderr+ swap put-at ] when* over timeout>> [ +timeout+ swap put-at ] when* @@ -73,8 +74,8 @@ TUPLE: process* arguments stdout stderr timeout ; : cat ( file -- ) contents print ; : run-or-bail ( desc quot -- ) - [ [ try-process ] curry ] - [ [ throw ] curry ] + [ [ try-process ] curry ] + [ [ throw ] compose ] bi* recover ; From 67fa873d9cd845ba87a96703cb44029583fbc226 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 14 Feb 2008 05:21:02 -0600 Subject: [PATCH 19/58] benchmark.sockets: run more clients --- extra/benchmark/sockets/sockets.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index e8efc11c32..f19a2127a5 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -22,7 +22,7 @@ IN: benchmark.sockets CHAR: x write1 ] with-stream ; -: socket-benchmark ( n -- ) +: clients ( n -- ) dup pprint " clients: " write [ [ simple-server ] in-thread @@ -33,11 +33,12 @@ IN: benchmark.sockets ] time ; : socket-benchmarks - 10 socket-benchmark - 20 socket-benchmark - 40 socket-benchmark - 80 socket-benchmark - 160 socket-benchmark - 320 socket-benchmark ; + 10 clients + 20 clients + 40 clients + 80 clients + 160 clients + 320 clients + 640 clients ; MAIN: socket-benchmarks From 8ab49d97bb8bac4195af6e4748d1e0e3a4e1071f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 14:17:17 -0600 Subject: [PATCH 20/58] Change run-tests as per erg's request --- extra/tools/test/test.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 62a4dab1eb..5c5d397df7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -54,11 +54,9 @@ SYMBOL: this-test : (run-test) ( vocab -- ) dup vocab-source-loaded? [ [ "temporary" forget-vocab ] with-compilation-unit - vocab-tests dup [ run-file ] each - [ - dup [ forget-source ] each - "temporary" forget-vocab - ] with-compilation-unit + vocab-tests + dup [ forget-source ] each + dup [ run-file ] each ] when drop ; : run-test ( vocab -- failures ) From 984aaa2544d451ea955f8c1d96c927a33f550b0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 14:19:42 -0600 Subject: [PATCH 21/58] Fix tests again --- extra/tools/test/test.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 5c5d397df7..69093f18a6 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -53,9 +53,11 @@ SYMBOL: this-test : (run-test) ( vocab -- ) dup vocab-source-loaded? [ - [ "temporary" forget-vocab ] with-compilation-unit vocab-tests - dup [ forget-source ] each + [ + "temporary" forget-vocab + dup [ forget-source ] each + ] with-compilation-unit dup [ run-file ] each ] when drop ; From f8c99c864b05ac79a66dc77cca5c318970983c8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 15:17:01 -0600 Subject: [PATCH 22/58] Loop conversion work in progress --- core/optimizer/control/control.factor | 62 ++++++++++++++------------- core/optimizer/optimizer-tests.factor | 22 ++++++++++ 2 files changed, 55 insertions(+), 29 deletions(-) diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index de3aeb220a..eed69f243b 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -135,15 +135,6 @@ M: #call-label detect-loops* r> [ set-node-successor ] keep ; ! ! ! Lifting code after a conditional if one branch throws -: only-one ( seq -- elt/f ) - dup length 1 = [ first ] [ drop f ] if ; - -: lift-throw-tail? ( #if -- tail/? ) - dup node-successor #tail? - [ drop f ] [ active-children only-one ] if ; - -: clone-node ( node -- newnode ) - clone dup [ clone ] modify-values ; ! BEFORE ! @@ -177,7 +168,17 @@ M: #call-label detect-loops* ! the same node as (***) ! ! Note: if (**) is #return is is sound to put #terminate there, -! but not if (**) is #values +! but not if (**) is # + +: only-one ( seq -- elt/f ) + dup length 1 = [ first ] [ drop f ] if ; + +: lift-throw-tail? ( #if -- tail/? ) + dup node-successor #tail? + [ drop f ] [ active-children only-one ] if ; + +: clone-node ( node -- newnode ) + clone dup [ clone ] modify-values ; : lift-branch over @@ -196,20 +197,6 @@ M: #if optimize-node* ] if ] if ; -: fold-dispatch-branch? dup node-in-d first tuck node-literal? ; - -: fold-dispatch-branch ( node value -- node' ) - dupd node-literal - over drop-inputs >r fold-branch r> - [ set-node-successor ] keep ; - -M: #dispatch optimize-node* - dup fold-dispatch-branch? [ - fold-dispatch-branch t - ] [ - 2drop t f - ] if ; - ! Loop tail hoising: code after a loop can sometimes go in the ! non-recursive branch of the loop @@ -247,6 +234,27 @@ M: #dispatch optimize-node* ! | ! #return 1 +: find-tail + dup node-successor #tail? + [ node-successor find-tail ] unless ; + +: child-tails ( node -- seq ) + node-children [ find-tail ] map ; + +GENERIC: add-loop-exit* ( label node -- ) + +M: #branch add-loop-exit* + child-tails [ add-loop-exit* ] with each ; + +M: #call-label add-loop-exit* drop ; + +M: node add-loop-exit* node-successor add-loop-exit* , ; + +: find-loop-exits ( label node -- seq ) + [ add-loop-exit* ] { } make ; + +! ! ! ! + : find-final-if ( node -- #if/f ) dup [ dup #if? [ @@ -264,11 +272,7 @@ M: #dispatch optimize-node* : lift-loop-tail? ( #label -- tail/f ) dup node-successor node-successor [ dup node-param swap node-child find-final-if dup [ - node-children [ penultimate-node ] map - [ - dup #call-label? - [ node-param eq? not ] [ 2drop t ] if - ] with subset only-one + find-loop-exits only-one ] [ 2drop f ] if ] [ drop f ] if ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6a76892246..c997a6eb51 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -329,3 +329,25 @@ TUPLE: silly-tuple a b ; 10 [ ] lift-loop-tail-test-1 1 2 3 ; [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test From 3696ce8168beb51d530d78b5d16a203e49a2bb96 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 15:19:13 -0600 Subject: [PATCH 23/58] Clarify docs --- core/threads/threads-docs.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) mode change 100644 => 100755 core/threads/threads-docs.factor diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor old mode 100644 new mode 100755 index 181979bfed..ece90d9a11 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -9,6 +9,7 @@ $nl { $subsection in-thread } { $subsection yield } { $subsection sleep } +"Threads stop either when the quotation given to " { $link in-thread } " returns, or when the following word is called:" { $subsection stop } "Continuations can be added to the run queue directly:" { $subsection schedule-thread } @@ -21,7 +22,8 @@ ABOUT: "threads" HELP: run-queue { $values { "queue" dlist } } -{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; +{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } +" and dequeued with " { $link pop-back } "." } ; HELP: schedule-thread { $values { "continuation" "a continuation reified by " { $link callcc0 } } } From d14ee13f64d4bfb72a502ab0c57700f1c7ad027d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 17:46:04 -0600 Subject: [PATCH 24/58] Remove tail-dispatch? optimization since it was not sound --- core/compiler/tests/templates.factor | 17 ++++++++++++++++- core/generator/generator.factor | 11 ++--------- 2 files changed, 18 insertions(+), 10 deletions(-) diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 74e5ab80a4..4be700f221 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts -words definitions compiler.units ; +words definitions compiler.units io combinators ; IN: temporary ! Oops! @@ -191,3 +191,18 @@ TUPLE: my-tuple ; 2 1 [ 2dup fixnum< [ >r die r> ] when ] compile-call ] unit-test + +! Regression +: a-dummy drop "hi" print ; + +[ ] [ + 1 [ + dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [ + drop - >fixnum { + [ a-dummy ] + [ a-dummy ] + [ a-dummy ] + } dispatch + ] [ 2drop no-case ] if + ] compile-call +] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 8b6742e700..e6a6226afa 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -158,17 +158,10 @@ M: #if generate-node ] with-generator ] keep ; -: tail-dispatch? ( node -- ? ) - #! Is the dispatch a jump to a tail call to a word? - dup #call? swap node-successor #return? and ; - : dispatch-branches ( node -- ) node-children [ - dup tail-dispatch? [ - node-param - ] [ - compiling-word get dispatch-branch - ] if %dispatch-label + compiling-word get dispatch-branch + %dispatch-label ] each ; : generate-dispatch ( node -- ) From f944f2b20c38bbf3a54f3534ea9181b775370d21 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 17:56:47 -0600 Subject: [PATCH 25/58] Add experimental disassembler --- core/alien/compiler/compiler.factor | 2 +- core/words/words-docs.factor | 4 +-- extra/tools/disassembler/authors.txt | 1 + extra/tools/disassembler/disassembler.factor | 31 ++++++++++++++++++++ extra/tools/disassembler/summary.txt | 1 + extra/unix/unix.factor | 1 + vm/types.c | 8 +++-- 7 files changed, 42 insertions(+), 6 deletions(-) create mode 100644 extra/tools/disassembler/authors.txt create mode 100644 extra/tools/disassembler/disassembler.factor create mode 100644 extra/tools/disassembler/summary.txt diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 282a849c34..f68bdcf0a2 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -326,7 +326,7 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt ] curry + alien-callback-xt [ word-xt drop ] curry recursive-state get infer-quot ; \ alien-callback [ diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 62848e46b2..91b5295427 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -245,8 +245,8 @@ HELP: remove-word-prop { $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." } { $side-effects "word" } ; -HELP: word-xt -{ $values { "word" word } { "xt" "an execution token integer" } } +HELP: word-xt ( word -- start end ) +{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } } { $description "Outputs the machine code address of the word's definition." } ; HELP: define-symbol diff --git a/extra/tools/disassembler/authors.txt b/extra/tools/disassembler/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/disassembler/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor new file mode 100644 index 0000000000..b7c88517c7 --- /dev/null +++ b/extra/tools/disassembler/disassembler.factor @@ -0,0 +1,31 @@ +USING: io.files io words alien kernel math.parser alien.syntax +io.launcher system assocs arrays ; +IN: tools.disassembler + +GENERIC: make-disassemble-cmd ( word -- file ) + +M: word make-disassemble-cmd + word-xt 2array make-disassemble-cmd ; + +M: pair make-disassemble-cmd + "gdb.txt" resource-path [ + [ + "disassemble " write + [ number>string write bl ] each + ] with-file-out + ] keep ; + +: run-gdb ( cmds -- output ) + [ + +closed+ +stdin+ set + [ + "gdb" , + vm , + getpid number>string , + "-x" , , + "-batch" , + ] { } make +arguments+ set + ] { } make-assoc contents ; + +: disassemble ( word -- ) + make-disassemble-cmd run-gdb write ; diff --git a/extra/tools/disassembler/summary.txt b/extra/tools/disassembler/summary.txt new file mode 100644 index 0000000000..f1a689c877 --- /dev/null +++ b/extra/tools/disassembler/summary.txt @@ -0,0 +1 @@ +Disassemble words using gdb diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 59141c1940..9d5a6122a2 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -125,6 +125,7 @@ FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; FUNCTION: char* getcwd ( char* buf, size_t size ) ; +FUNCTION: pid_t getpid ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/vm/types.c b/vm/types.c index 78e74535b8..fb61213385 100755 --- a/vm/types.c +++ b/vm/types.c @@ -70,11 +70,13 @@ DEFINE_PRIMITIVE(word) dpush(tag_object(allot_word(vocab,name))); } -/* word-xt ( word -- xt ) */ +/* word-xt ( word -- start end ) */ DEFINE_PRIMITIVE(word_xt) { - F_WORD *word = untag_word(dpeek()); - drepl(allot_cell((CELL)word->xt)); + F_WORD *word = untag_word(dpop()); + F_COMPILED *code = word->code; + dpush(allot_cell((CELL)code + sizeof(F_COMPILED))); + dpush(allot_cell((CELL)code + sizeof(F_COMPILED) + code->code_length)); } DEFINE_PRIMITIVE(wrapper) From 15ba74aaf8f53a2ea5540bed0dc61f5c4e0f944f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:27:04 -0600 Subject: [PATCH 26/58] Improved disassembler a bit --- extra/tools/disassembler/authors.txt | 1 + extra/tools/disassembler/disassembler.factor | 50 ++++++++++++-------- 2 files changed, 32 insertions(+), 19 deletions(-) diff --git a/extra/tools/disassembler/authors.txt b/extra/tools/disassembler/authors.txt index 1901f27a24..ef44eb9634 100644 --- a/extra/tools/disassembler/authors.txt +++ b/extra/tools/disassembler/authors.txt @@ -1 +1,2 @@ Slava Pestov +Jorge Acereda Macia diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index b7c88517c7..b74b2795cf 100644 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -1,31 +1,43 @@ +! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. +! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax -io.launcher system assocs arrays ; +io.launcher system assocs arrays sequences namespaces qualified +regexp system math ; +QUALIFIED: unix IN: tools.disassembler -GENERIC: make-disassemble-cmd ( word -- file ) +: in-file "gdb-in.txt" resource-path ; + +: out-file "gdb-out.txt" resource-path ; + +GENERIC: make-disassemble-cmd ( obj -- ) M: word make-disassemble-cmd - word-xt 2array make-disassemble-cmd ; + word-xt cell - 2array make-disassemble-cmd ; M: pair make-disassemble-cmd - "gdb.txt" resource-path [ - [ - "disassemble " write - [ number>string write bl ] each - ] with-file-out - ] keep ; + in-file [ + "attach " write + unix:getpid number>string print -: run-gdb ( cmds -- output ) + "disassemble " write + [ number>string write bl ] each + ] with-file-out ; + +: run-gdb ( -- lines ) [ +closed+ +stdin+ set - [ - "gdb" , - vm , - getpid number>string , - "-x" , , - "-batch" , - ] { } make +arguments+ set - ] { } make-assoc contents ; + out-file +stdout+ set + [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set + ] { } make-assoc run-process drop + out-file file-lines ; + +: relevant? ( line -- ? ) + R/ 0x.*:.*/ matches? ; + +: tabs>spaces ( str -- str' ) + [ dup CHAR: \t = [ drop CHAR: \s ] when ] map ; : disassemble ( word -- ) - make-disassemble-cmd run-gdb write ; + make-disassemble-cmd run-gdb + [ relevant? ] subset [ tabs>spaces ] map [ print ] each ; From 2a0df14200d11b3a3d568ec614f8af8fa4e909d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:27:18 -0600 Subject: [PATCH 27/58] Control flow analysis work in progress --- core/inference/dataflow/dataflow-docs.factor | 3 +- core/inference/dataflow/dataflow.factor | 6 +- core/inference/known-words/known-words.factor | 2 +- core/optimizer/control/control-tests.factor | 88 ++++++++++++++++++- core/optimizer/control/control.factor | 22 +++-- core/optimizer/optimizer-tests.factor | 2 +- 6 files changed, 110 insertions(+), 13 deletions(-) diff --git a/core/inference/dataflow/dataflow-docs.factor b/core/inference/dataflow/dataflow-docs.factor index 0f809fa2bd..66b3590253 100755 --- a/core/inference/dataflow/dataflow-docs.factor +++ b/core/inference/dataflow/dataflow-docs.factor @@ -1,4 +1,5 @@ -USING: inference.dataflow help.syntax help.markup ; +USING: help.syntax help.markup ; +IN: inference.dataflow HELP: #return { $values { "label" "a word or " { $link f } } { "node" "a new " { $link node } } } diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 9bca648b08..23b5343c9c 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -317,4 +317,8 @@ UNION: #tail POSTPONE: f #return #tail-values #tail-merge #terminate ; : tail-call? ( -- ? ) - node-stack get [ node-successor #tail? ] all? ; + #! We don't consider calls which do non-local exits to be + #! tail calls, because this gives better error traces. + node-stack get [ + node-successor dup #tail? swap #terminate? not and + ] all? ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index e6479d0c6a..9d0f959b68 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -345,7 +345,7 @@ M: object infer-call \ { object object } { word } set-primitive-effect \ make-flushable -\ word-xt { word } { integer } set-primitive-effect +\ word-xt { word } { integer integer } set-primitive-effect \ word-xt make-flushable \ getenv { fixnum } { object } set-primitive-effect diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index 2d52e6f45a..ab5c055fbd 100644 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -1,6 +1,7 @@ IN: temporary USING: tools.test optimizer.control combinators kernel -sequences inference.dataflow math inference ; +sequences inference.dataflow math inference classes strings +optimizer ; : label-is-loop? ( node word -- ? ) [ @@ -60,3 +61,88 @@ sequences inference.dataflow math inference ; [ loop-test-3 ] dataflow dup detect-loops \ loop-test-3 label-is-not-loop? ] unit-test + +: loop-test-4 ( a -- ) + dup [ + loop-test-4 + ] [ + drop + ] if ; inline + +: find-label ( node -- label ) + dup #label? [ node-successor find-label ] unless ; + +: test-loop-exits + dataflow dup detect-loops find-label + dup node-param swap + [ node-child find-tail find-loop-exits [ class ] map ] keep + #label-loop? ; + +[ { #values } t ] [ + [ loop-test-4 ] test-loop-exits +] unit-test + +: loop-test-5 ( a -- ) + dup [ + dup string? [ + loop-test-5 + ] [ + drop + ] if + ] [ + drop + ] if ; inline + +[ { #values #values } t ] [ + [ loop-test-5 ] test-loop-exits +] unit-test + +: loop-test-6 ( a -- ) + dup [ + dup string? [ + loop-test-6 + ] [ + 3 throw + ] if + ] [ + drop + ] if ; inline + +[ { #values } t ] [ + [ loop-test-6 ] test-loop-exits +] unit-test + +[ f ] [ + [ [ [ ] map ] map ] dataflow optimize + [ dup #label? swap #loop? not and ] node-exists? +] unit-test + +: blah f ; + +DEFER: a + +: b ( -- ) + blah [ b ] [ a ] if ; inline + +: a ( -- ) + blah [ b ] [ a ] if ; inline + +[ t ] [ + [ a ] dataflow dup detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] dataflow dup detect-loops + \ b label-is-loop? +] unit-test + +[ t ] [ + [ b ] dataflow dup detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] dataflow dup detect-loops + \ b label-is-loop? +] unit-test diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index eed69f243b..c9b3458d2a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -68,7 +68,7 @@ M: #label detect-loops* t swap set-#label-loop? ; node-stack get dup [ #label? ] find-last drop [ 1+ ] [ 0 ] if* tail [ node-successor #tail? ] all? ; - +USE: io : detect-loop ( seen-other? label node -- seen-other? continue? ) #! seen-other?: have we seen another label? { @@ -234,9 +234,12 @@ M: #if optimize-node* ! | ! #return 1 -: find-tail - dup node-successor #tail? - [ node-successor find-tail ] unless ; +: find-tail ( node -- tail ) + dup #terminate? [ + dup node-successor #tail? [ + node-successor find-tail + ] unless + ] unless ; : child-tails ( node -- seq ) node-children [ find-tail ] map ; @@ -246,15 +249,18 @@ GENERIC: add-loop-exit* ( label node -- ) M: #branch add-loop-exit* child-tails [ add-loop-exit* ] with each ; -M: #call-label add-loop-exit* drop ; +M: #call-label add-loop-exit* + tuck node-param eq? [ drop ] [ node-successor , ] if ; -M: node add-loop-exit* node-successor add-loop-exit* , ; +M: #terminate add-loop-exit* + 2drop ; + +M: node add-loop-exit* + nip node-successor dup #terminate? [ drop ] [ , ] if ; : find-loop-exits ( label node -- seq ) [ add-loop-exit* ] { } make ; -! ! ! ! - : find-final-if ( node -- #if/f ) dup [ dup #if? [ diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index c997a6eb51..7092797acc 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining ; +continuations growable optimizer.inlining namespaces ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ From 53c1ff1cc8092a5007474dc886424dda33d76add Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:27:25 -0600 Subject: [PATCH 28/58] Make a word inline --- core/sequences/sequences.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 967fcbbdc8..ee38d30750 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -257,7 +257,7 @@ INSTANCE: repetition immutable-sequence : check-copy ( src n dst -- ) over 0 < [ bounds-error ] when - >r swap length + r> lengthen ; + >r swap length + r> lengthen ; inline PRIVATE> From 333bf9ce16094b5cd55f4e8c4eead4128b16c81d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:27:34 -0600 Subject: [PATCH 29/58] Clean up math combination --- core/generic/math/math.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 2cc28ac0d1..0b2b9fcca3 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -58,16 +58,15 @@ TUPLE: no-math-method left right generic ; 2drop object-method ] if ; -: math-vtable* ( picker max quot -- quot ) +: math-vtable ( picker quot -- quot ) [ - rot , \ tag , - [ >r [ bootstrap-type>class ] map r> map % ] { } make , + >r + , \ tag , + num-tags get [ bootstrap-type>class ] + r> compose map , \ dispatch , ] [ ] make ; inline -: math-vtable ( picker quot -- quot ) - num-tags get swap math-vtable* ; inline - TUPLE: math-combination ; M: math-combination make-default-method From 9a459d3c124d223b54d6466542f7f9cd51012aa2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:27:48 -0600 Subject: [PATCH 30/58] Updating unit tests --- core/alien/structs/structs-tests.factor | 24 +++++++++++++----------- core/compiler/tests/simple.factor | 3 +++ 2 files changed, 16 insertions(+), 11 deletions(-) diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b2da0e8392..b934cd56a3 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -9,18 +9,20 @@ C-STRUCT: bar [ 36 ] [ "bar" heap-size ] unit-test [ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test -C-STRUCT: align-test - { "int" "x" } - { "double" "y" } ; +! This was actually only correct on Windows/x86: -[ 16 ] [ "align-test" heap-size ] unit-test - -cell 4 = [ - C-STRUCT: one - { "long" "a" } { "double" "b" } { "int" "c" } ; - - [ 24 ] [ "one" heap-size ] unit-test -] when +! C-STRUCT: align-test +! { "int" "x" } +! { "double" "y" } ; +! +! [ 16 ] [ "align-test" heap-size ] unit-test +! +! cell 4 = [ +! C-STRUCT: one +! { "long" "a" } { "double" "b" } { "int" "c" } ; +! +! [ 24 ] [ "one" heap-size ] unit-test +! ] when : MAX_FOOS 30 ; diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 1ed43120d3..6deed6c756 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -227,3 +227,6 @@ M: f single-combination-test-2 single-combination-test-4 ; [ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test [ f ] [ f single-combination-test-2 ] unit-test + +! Regression +[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test From 1c63a443a3d5f7d499ad1e1dcace9b36ce6ae1be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:28:16 -0600 Subject: [PATCH 31/58] optimizer.debugger now shows which nodes are loops --- extra/optimizer/debugger/debugger.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index ebf14417c0..db65a678cf 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -82,7 +82,10 @@ M: #call node>quot #call>quot ; M: #call-label node>quot #call>quot ; M: #label node>quot - [ "#label: " over node-param word-name append comment, ] 2keep + [ + dup #label-loop? "#loop: " "#label: " ? + over node-param word-name append comment, + ] 2keep node-child swap dataflow>quot , \ call , ; M: #if node>quot From d77c84be199fac59cc741d5ddb7939b8f7189788 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Feb 2008 20:38:46 -0600 Subject: [PATCH 32/58] Move unicode.data:replace to sequences.lib and refactor it --- extra/sequences/lib/lib.factor | 3 +++ extra/tools/disassembler/disassembler.factor | 4 ++-- extra/unicode/data/data.factor | 10 ++++------ 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1beec90b75..4c0ea04f24 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -205,3 +205,6 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: replace ( seq old new -- newseq ) + [ pick pick = [ 2nip ] [ 2drop ] if ] 2curry map ; diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index b74b2795cf..641eae90c2 100644 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -regexp system math ; +regexp system math sequences.lib ; QUALIFIED: unix IN: tools.disassembler @@ -36,7 +36,7 @@ M: pair make-disassemble-cmd R/ 0x.*:.*/ matches? ; : tabs>spaces ( str -- str' ) - [ dup CHAR: \t = [ drop CHAR: \s ] when ] map ; + CHAR: \t CHAR: \s replace ; : disassemble ( word -- ) make-disassemble-cmd run-gdb diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 3af3d927d7..419d3bcefd 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,7 @@ -USING: assocs math kernel sequences io.files hashtables -quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units parser ; +USING: assocs math kernel sequences sequences.lib io.files +hashtables quotations splitting arrays math.parser +combinators.lib hash2 byte-arrays words namespaces words +compiler.units parser ; IN: unicode.data << @@ -93,9 +94,6 @@ IN: unicode.data : ascii-lower ( string -- lower ) [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; -: replace ( seq old new -- newseq ) - swap rot [ 2dup = [ drop over ] when ] map 2nip ; - : process-names ( data -- names-hash ) 1 swap (process-data) [ ascii-lower CHAR: \s CHAR: - replace swap ] assoc-map From 09569ee5127fbe23fdfc30edb3787f56c01f6b4a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Feb 2008 23:29:06 -0600 Subject: [PATCH 33/58] add current-process-handle to io.launcher make tools.disassembler work on windows --- extra/io/launcher/launcher.factor | 2 ++ extra/io/unix/launcher/launcher.factor | 4 +++- extra/io/windows/launcher/launcher.factor | 3 +++ extra/tools/disassembler/disassembler.factor | 6 ++---- extra/windows/kernel32/kernel32.factor | 2 +- 5 files changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 6e6d79d8a4..dce893dcaf 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -76,6 +76,8 @@ SYMBOL: +append-environment+ { [ dup assoc? ] [ >hashtable ] } } cond ; +HOOK: current-process-handle io-backend ( -- handle ) + HOOK: run-process* io-backend ( desc -- handle ) : wait-for-process ( process -- status ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index c14b11029b..5adf0d7453 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process parser-combinators memoize -promises strings threads ; +promises strings threads unix ; IN: io.unix.launcher ! Search unix first @@ -71,6 +71,8 @@ MEMO: 'arguments' ( -- parser ) io-error ] [ error. :c flush ] recover 1 exit ; +M: unix-io current-process-handle ( -- handle ) getpid ; + M: unix-io run-process* ( desc -- pid ) [ [ spawn-process ] [ ] with-fork diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 475a4ddef6..cc3278dadc 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -102,6 +102,9 @@ M: windows-ce-io fill-redirection ; fill-lpEnvironment fill-startup-info ; +M: windows-io current-process-handle ( -- handle ) + GetCurrentProcessId ; + M: windows-io run-process* ( desc -- handle ) [ [ diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 641eae90c2..f9e6e284de 100644 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -regexp system math sequences.lib ; -QUALIFIED: unix +regexp system math sequences.lib windows.kernel32 ; IN: tools.disassembler : in-file "gdb-in.txt" resource-path ; @@ -18,8 +17,7 @@ M: word make-disassemble-cmd M: pair make-disassemble-cmd in-file [ "attach " write - unix:getpid number>string print - + current-process-handle number>string print "disassemble " write [ number>string write bl ] each ] with-file-out ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index b8928c5820..3574df36db 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -895,7 +895,7 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; : GetCurrentDirectory GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; -! FUNCTION: GetCurrentProcessId +FUNCTION: DWORD GetCurrentProcessId ( ) ; FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetCurrentThreadId ! FUNCTION: GetDateFormatA From 64e64fd6ae44829986b61cb7400e1de0683ae219 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Feb 2008 23:34:20 -0600 Subject: [PATCH 34/58] document current-process-handle --- extra/io/launcher/launcher-docs.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4f5a85244b..3a557e9fd5 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -90,6 +90,10 @@ HELP: get-environment { $values { "env" "an association" } } { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; +HELP: current-process-handle +{ $values { "handle" "a process handle" } } +{ $description "Returns the handle of the current process." } ; + HELP: run-process* { $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } { $contract "Launches a process using the launch descriptor." } @@ -186,6 +190,8 @@ ARTICLE: "io.launcher" "Launching OS processes" { $subsection try-process } "Stopping processes:" { $subsection kill-process } +"Finding the current process handle:" +{ $subsection current-process-handle } "Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } From def53a07d8ab0882e91dddb7ebd4615249ae7737 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Feb 2008 23:39:20 -0600 Subject: [PATCH 35/58] lose the bad codez in sqlite change the db api to more-rows? and advance-row instead of just advance-row sql-command takes a string or a seq of strings postgresql create-sql handles native/assigned ids --- extra/db/db.factor | 29 +++++---- extra/db/postgresql/postgresql.factor | 87 ++++++++++++++------------- extra/db/sqlite/lib/lib.factor | 8 +-- extra/db/sqlite/sqlite.factor | 31 ++++------ extra/db/tuples/tuples-tests.factor | 9 +-- extra/db/tuples/tuples.factor | 5 +- extra/db/types/types.factor | 6 ++ 7 files changed, 92 insertions(+), 83 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 365f0c009c..3595558dec 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math -namespaces sequences sequences.lib tuples words ; +namespaces sequences sequences.lib tuples words strings ; IN: db TUPLE: db handle insert-statements update-statements delete-statements select-statements ; @@ -37,14 +37,14 @@ GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) GENERIC: insert-statement ( statement -- id ) -HOOK: last-id db ( res -- id ) TUPLE: result-set sql params handle n max ; GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) -GENERIC: advance-row ( result-set -- ? ) +GENERIC: advance-row ( result-set -- ) +GENERIC: more-rows? ( result-set -- ? ) : execute-statement ( statement -- ) query-results dispose ; @@ -56,7 +56,7 @@ GENERIC: advance-row ( result-set -- ? ) : init-result-set ( result-set -- ) dup #rows over set-result-set-max - -1 swap set-result-set-n ; + 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) >r >r { statement-sql statement-params } get-slots r> @@ -70,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? ) dup #columns [ row-column ] with map ; : query-each ( statement quot -- ) - over advance-row [ - 2drop + over more-rows? [ + [ call ] 2keep over advance-row query-each ] [ - [ call ] 2keep query-each + 2drop ] if ; inline : query-map ( statement quot -- seq ) @@ -94,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? ) : do-bound-command ( obj query -- ) [ bind-statement ] keep execute-statement ; -: sql-query ( sql -- rows ) - [ do-query ] with-disposal ; - -: sql-command ( sql -- ) - [ execute-statement ] with-disposal ; SYMBOL: in-transaction HOOK: begin-transaction db ( -- ) @@ -112,3 +107,13 @@ HOOK: rollback-transaction db ( -- ) begin-transaction [ ] [ rollback-transaction ] cleanup commit-transaction ] with-variable ; + +: sql-query ( sql -- rows ) + [ do-query ] with-disposal ; + +: sql-command ( sql -- ) + dup string? [ + [ execute-statement ] with-disposal + ] [ + [ [ sql-command ] each ] with-transaction + ] if ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 93c66708b4..f198a5c04c 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -3,7 +3,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi -db.tuples db.types tools.annotations ; +db.tuples db.types tools.annotations math.ranges ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -52,14 +52,8 @@ M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set row-column ( result-set n -- obj ) >r dup result-set-handle swap result-set-n r> PQgetvalue ; -M: postgresql-statement execute-statement ( statement -- obj ) - query-results dispose ; - M: postgresql-statement insert-statement ( statement -- id ) - query-results dispose ; - -: increment-n ( result-set -- n ) - dup result-set-n 1+ dup rot set-result-set-n ; + query-results [ break 0 row-column ] with-disposal ; M: postgresql-statement query-results ( query -- result-set ) dup statement-params [ @@ -71,8 +65,11 @@ M: postgresql-statement query-results ( query -- result-set ) postgresql-result-set dup init-result-set ; -M: postgresql-result-set advance-row ( result-set -- ? ) - dup increment-n swap result-set-max >= ; +M: postgresql-result-set advance-row ( result-set -- ) + dup result-set-n 1+ swap set-result-set-n ; + +M: postgresql-result-set more-rows? ( result-set -- ? ) + dup result-set-n swap result-set-max < ; M: postgresql-statement dispose ( query -- ) dup statement-handle PQclear @@ -108,15 +105,6 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; -SYMBOL: postgresql-counter - -: make-postgresql-counter ( quot -- ) - [ postgresql-counter off ] swap compose "" make ; - -: counter% ( -- ) - CHAR: $ , - postgresql-counter [ inc ] keep get # ; - : postgresql-type-hash* ( -- assoc ) H{ { SERIAL "serial" } @@ -156,16 +144,9 @@ M: postgresql-db >sql-type ( hash obj -- str ) ] unless ] if ; -M: postgresql-db create-sql ( columns table -- sql ) +: insert-function ( columns table -- sql ) [ - 2dup - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type* % " " % - sql-modifiers " " join % - ] interleave "); " % - + >r remove-id r> "create function add_" % dup % "(" % over [ "," % ] @@ -179,33 +160,52 @@ M: postgresql-db create-sql ( columns table -- sql ) dup [ ", " % ] [ second % ] interleave ") " % " values (" % - [ ", " % ] [ drop counter% ] interleave + length [1,b] [ ", " % ] [ "$" % # ] interleave "); " % "select currval(''" % % "_id_seq'');' language sql;" % drop - ] make-postgresql-counter dup . ; + ] "" make ; -M: postgresql-db drop-sql ( columns table -- sql ) +: drop-function ( columns table -- sql ) [ - dup "drop table " % % - "; drop function add_" % % + >r remove-id r> + "drop function add_" % % "(" % [ "," % ] [ third >sql-type % ] interleave ")" % - ] "" make ; -! \ create-sql reset -! \ create-sql watch +M: postgresql-db create-sql ( columns table -- seq ) + [ + [ + 2dup + "create table " % % + " (" % [ ", " % ] [ + dup second % " " % + dup third >sql-type* % " " % + sql-modifiers " " join % + ] interleave "); " % + ] "" make , + + over native-id? [ insert-function , ] [ 2drop ] if + ] { } make ; + +M: postgresql-db drop-sql ( columns table -- seq ) + [ + [ + dup "drop table " % % ";" % + ] "" make , + over native-id? [ drop-function , ] [ 2drop ] if + ] { } make ; M: postgresql-db insert-sql* ( columns table -- sql ) [ "select add_" % % "(" % - [ ", " % ] [ counter% ] interleave + length [1,b] [ ", " % ] [ "$" % # ] interleave ")" % - ] make-postgresql-counter ; + ] "" make ; M: postgresql-db update-sql* ( columns table -- sql ) [ @@ -213,18 +213,19 @@ M: postgresql-db update-sql* ( columns table -- sql ) % " set " % dup remove-id - [ ", " % ] [ second % " = " % counter% ] interleave + dup length [1,b] swap 2array flip + [ ", " % ] [ first2 second % " = $" % # ] interleave " where " % - [ primary-key? ] find nip second dup % " = " % counter% - ] make-postgresql-counter ; + [ primary-key? ] find nip second dup % " = $" % length 2 + # + ] "" make ; M: postgresql-db delete-sql* ( columns table -- sql ) [ "delete from " % % " where " % - first second dup % " = " % counter% - ] make-postgresql-counter ; + first second % " = $1" % + ] "" make ; M: postgresql-db select-sql* ( columns table -- sql ) drop ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 2c0f2ae130..dfa8a4b2dc 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -100,13 +100,13 @@ IN: db.sqlite.lib : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; -: step-complete? ( step-result -- bool ) +: sqlite-step-has-more-rows? ( step-result -- bool ) dup SQLITE_ROW = [ - drop f + drop t ] [ dup SQLITE_DONE = - [ drop ] [ sqlite-check-result ] if t + [ drop ] [ sqlite-check-result ] if f ] if ; : sqlite-next ( prepared -- ? ) - sqlite3_step step-complete? ; + sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d83642bd8c..298220b3ca 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ; TUPLE: sqlite-statement ; C: sqlite-statement -TUPLE: sqlite-result-set advanced? ; -: ( query -- sqlite-result-set ) - dup statement-handle sqlite-result-set ; +TUPLE: sqlite-result-set has-more? ; M: sqlite-db ( str -- obj ) ; @@ -40,13 +38,7 @@ M: sqlite-db ( str -- obj ) M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; -: maybe-advance-row ( result-set -- result-set ) - dup sqlite-result-set-advanced? [ - dup advance-row drop - ] unless ; - M: sqlite-result-set dispose ( result-set -- ) - maybe-advance-row f swap set-result-set-handle ; : sqlite-bind ( triples handle -- ) @@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- ) M: sqlite-statement reset-statement ( statement -- ) statement-handle sqlite-reset ; +: last-insert-id ( -- id ) + db get db-handle sqlite3_last_insert_rowid + dup zero? [ "last-id failed" throw ] when ; + M: sqlite-statement insert-statement ( statement -- id ) - query-results [ last-id ] with-disposal ; + execute-statement last-insert-id ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -67,12 +63,16 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set advance-row ( result-set -- handle ? ) +M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep - t swap set-sqlite-result-set-advanced? ; + set-sqlite-result-set-has-more? ; + +M: sqlite-result-set more-rows? ( result-set -- ? ) + sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) - dup statement-handle sqlite-result-set ; + dup statement-handle sqlite-result-set + dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -145,11 +145,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) dupd >r first r> get-slot-named swap third 3array ] curry map ; - -M: sqlite-db last-id ( result-set -- id ) - maybe-advance-row drop - db get db-handle sqlite3_last_insert_rowid - dup zero? [ "last-id failed" throw ] when ; : sqlite-db-modifiers ( -- hashtable ) H{ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index cb4129965c..72fb6396b5 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -30,7 +30,8 @@ SYMBOL: the-person [ ] [ the-person get update-tuple ] unit-test - [ ] [ the-person get delete-tuple ] unit-test ; + [ ] [ the-person get delete-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ @@ -52,8 +53,8 @@ person "PERSON" "billy" 10 3.14 the-person set - test-sqlite -! test-postgresql +! test-sqlite +test-postgresql person "PERSON" { @@ -65,5 +66,5 @@ person "PERSON" 1 "billy" 20 6.28 the-person set - test-sqlite +! test-sqlite ! test-postgresql diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 1697de83d3..74726f12aa 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -38,8 +38,9 @@ TUPLE: no-slot-named ; [ db-table dupd ] swap [ ] 3compose cache nip ; inline -HOOK: create-sql db ( columns table -- sql ) -HOOK: drop-sql db ( columns table -- sql ) +HOOK: create-sql db ( columns table -- seq ) +HOOK: drop-sql db ( columns table -- seq ) + HOOK: insert-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 30c15682fa..7cacbcf861 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -11,6 +11,12 @@ SYMBOL: +assigned-id+ : primary-key? ( spec -- ? ) [ { +native-id+ +assigned-id+ } member? ] contains? ; +: contains-id? ( columns id -- ? ) + swap [ member? ] with contains? ; + +: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; +: native-id? ( columns -- ? ) +native-id+ contains-id? ; + ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ SYMBOL: +serial+ From f04eb21ef5694afb0720db18108f8c8abf413f52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 02:12:40 -0600 Subject: [PATCH 36/58] Load disassembler by default now that it works on Windows --- extra/help/handbook/handbook.factor | 11 ++++++++--- extra/tools/disassembler/disassembler-docs.factor | 12 ++++++++++++ extra/tools/disassembler/disassembler.factor | 9 +++------ extra/tools/memory/memory-docs.factor | 2 +- 4 files changed, 24 insertions(+), 10 deletions(-) create mode 100755 extra/tools/disassembler/disassembler-docs.factor mode change 100644 => 100755 extra/tools/disassembler/disassembler.factor mode change 100644 => 100755 extra/tools/memory/memory-docs.factor diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9472e1f519..b6b992344d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -161,15 +161,20 @@ ARTICLE: "io" "Input and output" { $subsection "io.timeouts" } ; ARTICLE: "tools" "Developer tools" -{ $subsection "tools.annotations" } -{ $subsection "tools.crossref" } +"Exploratory tools:" { $subsection "editor" } +{ $subsection "tools.crossref" } { $subsection "inspector" } +"Debugging tools:" +{ $subsection "tools.annotations" } +{ $subsection "tools.test" } { $subsection "meta-interpreter" } +"Performance tools:" { $subsection "tools.memory" } { $subsection "profiling" } -{ $subsection "tools.test" } { $subsection "timing" } +{ $subsection "tools.disassembler" } +"Deployment tools:" { $subsection "tools.deploy" } ; ARTICLE: "article-index" "Article index" diff --git a/extra/tools/disassembler/disassembler-docs.factor b/extra/tools/disassembler/disassembler-docs.factor new file mode 100755 index 0000000000..618413dcbd --- /dev/null +++ b/extra/tools/disassembler/disassembler-docs.factor @@ -0,0 +1,12 @@ +IN: tools.disassembler +USING: help.markup help.syntax ; + +HELP: disassemble +{ $values { "obj" "a word or a pair of addresses" } } +{ $description "Disassembles either a compiled word definition or an arbitrary memory range using " { $snippet "gdb" } "." } ; + +ARTICLE: "tools.disassembler" "Disassembling words" +"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "." +{ $subsection disassemble } ; + +ABOUT: "tools.disassembler" diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor old mode 100644 new mode 100755 index f9e6e284de..16ea58ac70 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -regexp system math sequences.lib windows.kernel32 ; +system math sequences.lib windows.kernel32 generator.fixup ; IN: tools.disassembler : in-file "gdb-in.txt" resource-path ; @@ -12,7 +12,7 @@ IN: tools.disassembler GENERIC: make-disassemble-cmd ( obj -- ) M: word make-disassemble-cmd - word-xt cell - 2array make-disassemble-cmd ; + word-xt code-format - 2array make-disassemble-cmd ; M: pair make-disassemble-cmd in-file [ @@ -30,12 +30,9 @@ M: pair make-disassemble-cmd ] { } make-assoc run-process drop out-file file-lines ; -: relevant? ( line -- ? ) - R/ 0x.*:.*/ matches? ; - : tabs>spaces ( str -- str' ) CHAR: \t CHAR: \s replace ; : disassemble ( word -- ) make-disassemble-cmd run-gdb - [ relevant? ] subset [ tabs>spaces ] map [ print ] each ; + [ tabs>spaces ] map [ print ] each ; diff --git a/extra/tools/memory/memory-docs.factor b/extra/tools/memory/memory-docs.factor old mode 100644 new mode 100755 index 939dda0cfc..11bb8d859b --- a/extra/tools/memory/memory-docs.factor +++ b/extra/tools/memory/memory-docs.factor @@ -17,7 +17,7 @@ ARTICLE: "tools.memory" "Object memory tools" "The garbage collector can be invoked manually:" { $subsection data-gc } { $subsection code-gc } -{ $see-also "image" } ; +{ $see-also "images" } ; ABOUT: "tools.memory" From 3409aa670d17ffed5e89badeb7f01fcbb0ed82c0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 02:21:01 -0600 Subject: [PATCH 37/58] builder.util: simpler cat and eval-file --- extra/builder/util/util.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index b3b88874b0..70f3083f57 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -69,9 +69,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ; : milli-seconds>time ( n -- string ) 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; -: eval-file ( file -- obj ) contents eval ; +: eval-file ( file -- obj ) file-contents eval ; -: cat ( file -- ) contents print ; +: cat ( file -- ) file-contents print ; : run-or-bail ( desc quot -- ) [ [ try-process ] curry ] From 51a589835ee3b61d4e9224f19fc2345e1410f446 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 02:37:26 -0600 Subject: [PATCH 38/58] Minor tweaks --- extra/benchmark/compiler/compiler.factor | 17 +++++++++++++++++ extra/bootstrap/tools/tools.factor | 3 ++- .../tools/disassembler/disassembler-docs.factor | 5 +++-- 3 files changed, 22 insertions(+), 3 deletions(-) create mode 100755 extra/benchmark/compiler/compiler.factor diff --git a/extra/benchmark/compiler/compiler.factor b/extra/benchmark/compiler/compiler.factor new file mode 100755 index 0000000000..12ac9b8041 --- /dev/null +++ b/extra/benchmark/compiler/compiler.factor @@ -0,0 +1,17 @@ +IN: benchmark.compiler +USING: assocs words sequences arrays compiler tools.time +io.styles io prettyprint vocabs kernel sorting generator +optimizer ; + +: recompile-with-timings + all-words [ compiled? ] subset + [ dup [ word-dataflow optimize nip drop ] benchmark nip ] { } map>assoc + sort-values 20 tail* + "Worst offenders:" print + standard-table-style + [ + [ [ "Word" write ] with-cell [ "Compile time (ms)" write ] with-cell ] with-row + [ [ [ pprint-cell ] each ] with-row ] each + ] tabular-output ; + +MAIN: recompile-with-timings diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 7b909ea1f6..40d77e03be 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -4,10 +4,11 @@ USING: vocabs.loader sequences ; "bootstrap.image" "tools.annotations" "tools.crossref" - ! "tools.deploy" + "tools.deploy" "tools.memory" "tools.profiler" "tools.test" "tools.time" + "tools.disassembler" "editors" } [ require ] each diff --git a/extra/tools/disassembler/disassembler-docs.factor b/extra/tools/disassembler/disassembler-docs.factor index 618413dcbd..f03861a8ed 100755 --- a/extra/tools/disassembler/disassembler-docs.factor +++ b/extra/tools/disassembler/disassembler-docs.factor @@ -1,9 +1,10 @@ IN: tools.disassembler -USING: help.markup help.syntax ; +USING: help.markup help.syntax sequences.private ; HELP: disassemble { $values { "obj" "a word or a pair of addresses" } } -{ $description "Disassembles either a compiled word definition or an arbitrary memory range using " { $snippet "gdb" } "." } ; +{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." } +{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse " { $snippet "gdb" } ". This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline. Also on the ARM architecture, various pointers are often compiled inline, and the preceeding instruction jumps over the inline pinter." } ; ARTICLE: "tools.disassembler" "Disassembling words" "The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "." From 978a4e28ebad25adc76e5d145222b4bf3855535c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 03:17:30 -0600 Subject: [PATCH 39/58] builder: minor tweaks --- extra/builder/builder.factor | 16 +++++++++++++--- extra/builder/util/util.factor | 3 +++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 00e39be2ba..572cd6d52c 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,13 +69,19 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : (build) ( -- ) + build-status off + enter-build-dir "report" [ "Build machine: " write host-name print + "CPU: " write cpu print + "OS: " write os print "Build directory: " write cwd print git-clone [ "git clone failed" print ] run-or-bail @@ -88,7 +94,7 @@ VAR: stamp make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail - [ my-arch download-image ] [ "Image download error" print throw ] recover + [ retrieve-image ] [ "Image download error" print throw ] recover bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail @@ -106,7 +112,9 @@ VAR: stamp "Benchmarks: " print "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks. - ] with-file-out ; + ] with-file-out + + build-status on ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -114,12 +122,14 @@ SYMBOL: builder-recipients : tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; +: subject ( -- str ) build-status get [ "report" ] [ "error" ] if ; + : build ( -- ) [ (build) ] [ drop ] recover "ed@factorcode.org" >>from builder-recipients get >>to - "report" tag-subject >>subject + subject >>subject "../report" file>string >>body send ; diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 70f3083f57..f9f432a8f6 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -81,3 +81,6 @@ TUPLE: process* arguments stdin stdout stderr timeout ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +USING: bootstrap.image bootstrap.image.download io.streams.null ; + +: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ; \ No newline at end of file From 50b38b0ae2e749fddd8390b34526464d688800d6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 05:22:52 -0600 Subject: [PATCH 40/58] builder: builds-dir variable and prepare-build-machine --- extra/builder/builder.factor | 39 +++++++++++++++++++++++++++++++----- 1 file changed, 34 insertions(+), 5 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 572cd6d52c..d502d0dfbd 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -11,6 +11,28 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: builds-dir + +: builds ( -- path ) + builds-dir get + home "/builds" append + or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! User also needs to set smtp-host and builder-recipients + +: prepare-build-machine ( -- ) + builds make-directory + builds cd + { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : git-clone ( -- desc ) { "git" "clone" "../factor" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -19,7 +41,7 @@ VAR: stamp : enter-build-dir ( -- ) datestamp >stamp - "/builds" cd + builds cd stamp> make-directory stamp> cd ; @@ -75,6 +97,8 @@ SYMBOL: build-status build-status off + builds-check + enter-build-dir "report" [ @@ -118,21 +142,26 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: builder-from + SYMBOL: builder-recipients : tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; -: subject ( -- str ) build-status get [ "report" ] [ "error" ] if ; +: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ; -: build ( -- ) - [ (build) ] [ drop ] recover +: send-builder-email ( -- ) - "ed@factorcode.org" >>from + builder-from get >>from builder-recipients get >>to subject >>subject "../report" file>string >>body send ; +: build ( -- ) + [ (build) ] [ drop ] recover + [ send-builder-email ] [ "not sending mail" . ] recover ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-pull ( -- desc ) From 8d86b51e76a89971dbb50011aa7155b631dd7c37 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 05:54:19 -0600 Subject: [PATCH 41/58] builder: do builds-check in build-loop --- extra/builder/builder.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d502d0dfbd..e6e1c4d94f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -97,8 +97,6 @@ SYMBOL: build-status build-status off - builds-check - enter-build-dir "report" [ @@ -160,7 +158,7 @@ SYMBOL: builder-recipients : build ( -- ) [ (build) ] [ drop ] recover - [ send-builder-email ] [ "not sending mail" . ] recover ; + [ send-builder-email ] [ drop "not sending mail" . ] recover ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -180,6 +178,7 @@ SYMBOL: builder-recipients = not ; : build-loop ( -- ) + builds-check [ "/builds/factor" cd updates-available? From da142685372f643d8669d4b6fae4f5387313971f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 05:57:44 -0600 Subject: [PATCH 42/58] builder: minor fix --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index e6e1c4d94f..a13392699a 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -180,7 +180,7 @@ SYMBOL: builder-recipients : build-loop ( -- ) builds-check [ - "/builds/factor" cd + builds cd updates-available? [ build ] when From 9a66a8f87b43d9099cfa7da223d985aae77a20a4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 06:04:53 -0600 Subject: [PATCH 43/58] builder: fix another bug --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a13392699a..84a3d6d66e 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -180,7 +180,7 @@ SYMBOL: builder-recipients : build-loop ( -- ) builds-check [ - builds cd + builds "/factor" append cd updates-available? [ build ] when From bdbd6365324d04bf4ecbfce7a38e3fde35d75f42 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 15 Feb 2008 07:46:20 -0600 Subject: [PATCH 44/58] builder: fix report formatting --- extra/builder/builder.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 84a3d6d66e..d491e1650b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -20,8 +20,6 @@ SYMBOL: builds-dir ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! User also needs to set smtp-host and builder-recipients - : prepare-build-machine ( -- ) builds make-directory builds cd @@ -104,7 +102,7 @@ SYMBOL: build-status "Build machine: " write host-name print "CPU: " write cpu print "OS: " write os print - "Build directory: " write cwd print + "Build directory: " write cwd print nl git-clone [ "git clone failed" print ] run-or-bail @@ -126,7 +124,7 @@ SYMBOL: build-status "Boot time: " write "../boot-time" eval-file milli-seconds>time print "Load time: " write "../load-time" eval-file milli-seconds>time print - "Test time: " write "../test-time" eval-file milli-seconds>time print + "Test time: " write "../test-time" eval-file milli-seconds>time print nl "Did not pass load-everything: " print "../load-everything-vocabs" cat "Did not pass test-all: " print "../test-all-vocabs" cat From 97fd5bee5fa1a66d42c638cac0b89ffc926e7483 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 16 Feb 2008 09:05:01 -0600 Subject: [PATCH 45/58] builder: (build) does builds-check --- extra/builder/builder.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d491e1650b..cd17a32255 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -93,6 +93,8 @@ SYMBOL: build-status : (build) ( -- ) + builds-check + build-status off enter-build-dir From 46df9c16d19dcdbc315492051720ef17e29351c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 Feb 2008 12:16:31 -0600 Subject: [PATCH 46/58] fix load error --- extra/db/postgresql/postgresql.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f198a5c04c..f0a008d065 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -52,6 +52,9 @@ M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set row-column ( result-set n -- obj ) >r dup result-set-handle swap result-set-n r> PQgetvalue ; +M: postgresql-result-set row-column ( result-set n -- obj ) + >r dup result-set-handle swap result-set-n r> PQgetvalue ; + M: postgresql-statement insert-statement ( statement -- id ) query-results [ break 0 row-column ] with-disposal ; @@ -234,9 +237,6 @@ M: postgresql-db tuple>params ( columns tuple -- obj ) [ >r dup third swap first r> get-slot-named swap ] curry { } map>assoc ; -M: postgresql-db last-id ( res -- id ) - drop f ; - : postgresql-db-modifiers ( -- hashtable ) H{ { +native-id+ "not null primary key" } From da716ed6ec7196fddcf3fc8a86b89bf85cc755dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 18:04:47 -0600 Subject: [PATCH 47/58] Rename benchmark.compiler to optimizer.report --- extra/benchmark/compiler/compiler.factor | 17 -------------- extra/optimizer/report/report.factor | 28 ++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 17 deletions(-) delete mode 100755 extra/benchmark/compiler/compiler.factor create mode 100755 extra/optimizer/report/report.factor diff --git a/extra/benchmark/compiler/compiler.factor b/extra/benchmark/compiler/compiler.factor deleted file mode 100755 index 12ac9b8041..0000000000 --- a/extra/benchmark/compiler/compiler.factor +++ /dev/null @@ -1,17 +0,0 @@ -IN: benchmark.compiler -USING: assocs words sequences arrays compiler tools.time -io.styles io prettyprint vocabs kernel sorting generator -optimizer ; - -: recompile-with-timings - all-words [ compiled? ] subset - [ dup [ word-dataflow optimize nip drop ] benchmark nip ] { } map>assoc - sort-values 20 tail* - "Worst offenders:" print - standard-table-style - [ - [ [ "Word" write ] with-cell [ "Compile time (ms)" write ] with-cell ] with-row - [ [ [ pprint-cell ] each ] with-row ] each - ] tabular-output ; - -MAIN: recompile-with-timings diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor new file mode 100755 index 0000000000..6655d9dcf3 --- /dev/null +++ b/extra/optimizer/report/report.factor @@ -0,0 +1,28 @@ +IN: optimizer.report +USING: assocs words sequences arrays compiler tools.time +io.styles io prettyprint vocabs kernel sorting generator +optimizer ; + +: count-optimization-passes ( nodes n -- n ) + >r optimize-1 + [ r> 1+ count-optimization-passes ] [ drop r> ] if ; + +: word-table + [ [ second ] swap compose compare ] curry sort 20 tail* + print + standard-table-style + [ + [ [ [ pprint-cell ] each ] with-row ] each + ] tabular-output ; + +: optimizer-report + all-words [ compiled? ] subset + [ + dup [ + word-dataflow nip 1 count-optimization-passes + ] benchmark nip 2array + ] { } map>assoc + [ first ] "Worst number of optimizer passes:" results + [ second ] "Worst compile times:" results ; + +MAIN: optimizer-report From 89e97fc89a03dcac41983b0ba0f9870bdf21c967 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 18:06:48 -0600 Subject: [PATCH 48/58] Debugger unit test for recent regression --- core/debugger/debugger-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) create mode 100755 core/debugger/debugger-tests.factor diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor new file mode 100755 index 0000000000..31c3e8a762 --- /dev/null +++ b/core/debugger/debugger-tests.factor @@ -0,0 +1,4 @@ +IN: temporary +USING: debugger kernel continuations tools.test ; + +[ ] [ [ drop ] [ error. ] recover ] unit-test From a4c3e8bda04f779d88a6311eeaf4de460acb6959 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 18:07:10 -0600 Subject: [PATCH 49/58] Load handbook last --- extra/bootstrap/handbook/handbook.factor | 3 + extra/bootstrap/help/help.factor | 4 +- extra/help/handbook/handbook.factor | 142 +---------------------- 3 files changed, 9 insertions(+), 140 deletions(-) create mode 100755 extra/bootstrap/handbook/handbook.factor diff --git a/extra/bootstrap/handbook/handbook.factor b/extra/bootstrap/handbook/handbook.factor new file mode 100755 index 0000000000..2ffb77de7a --- /dev/null +++ b/extra/bootstrap/handbook/handbook.factor @@ -0,0 +1,3 @@ +USING: vocabs.loader vocabs kernel ; + +"bootstrap.help" vocab [ "help.handbook" require ] when diff --git a/extra/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor index ade60d4457..1680278fad 100755 --- a/extra/bootstrap/help/help.factor +++ b/extra/bootstrap/help/help.factor @@ -14,8 +14,6 @@ IN: bootstrap.help [ vocab-root ] subset [ vocab-source-loaded? ] subset [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each - ] with-variable - - "help.handbook" require ; + ] with-variable ; load-help diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index b6b992344d..90e780c1ad 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -1,8 +1,8 @@ -USING: help help.markup help.syntax help.topics -namespaces words sequences classes assocs vocabs kernel -arrays prettyprint.backend kernel.private io tools.browser -generic math tools.profiler system ui strings sbufs vectors -byte-arrays bit-arrays float-arrays quotations help.lint ; +USING: help help.markup help.syntax help.definitions help.topics +namespaces words sequences classes assocs vocabs kernel arrays +prettyprint.backend kernel.private io generic math system +strings sbufs vectors byte-arrays bit-arrays float-arrays +quotations ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -206,7 +206,6 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "cookbook" } { $subsection "first-program" } { $subsection "vocab-index" } -{ $subsection "changes" } { $heading "Language reference" } { $subsection "conventions" } { $subsection "syntax" } @@ -236,137 +235,6 @@ ARTICLE: "handbook" "Factor documentation" { $subsection "type-index" } { $subsection "class-index" } ; - -USING: io.files io.sockets float-arrays inference ; - -ARTICLE: "changes" "Changes in the latest release" -{ $heading "Factor 0.91" } -{ $subheading "Performance" } -{ $list - { "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." } - { "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." } - { "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." } - { "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls. It offers a 33%-50% performance increase over the interpreter." } - { "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player." } - { "The queue of sleeping tasks is now a sorted priority queue. This reduces overhead for workloads involving large numbers of sleeping threads (Doug Coleman)" } - { "Improved hash code algorithm for sequences" } - { "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" } - { "New " { $link big-random } " word for generating large random numbers quickly" } - { "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." } - { "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." } -} -{ $subheading "IO" } -{ $list - { "More robust Windows CE native I/O" } - { "New " { $link os-envs } " word to get the current set of environment variables" } - { "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" } - { { $link } " implemented on Windows (Doug Coleman)" } - { "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" } - { { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" } - { { $vocab-link "io.server" } " - improved logging support, logs to a file by default" } - { { $vocab-link "io.files" } " - several new file system manipulation words added" } - { { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" } - { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." } -} -{ $subheading "Tools" } -{ $list - { "Graphical deploy tool added - see " { $link "ui.tools.deploy" } } - { "The deploy tool now supports Windows" } - { { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" } -} -{ $subheading "UI" } -{ $list - { { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" } - { { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" } - { { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" } - { "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" } - { "Windows can be closed on request now using " { $link close-window } } - { "New icons (Elie Chaftari)" } -} -{ $subheading "Libraries" } -{ $list - { "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } } - { "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." } - { "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." } - { { $vocab-link "benchmark.knucleotide" } " - new benchmark (Eric Mertens)" } - { { $vocab-link "channels" } " - concurrent message passing over message channels" } - { { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" } - { { $vocab-link "dlists" } " - various updates (Doug Coleman)" } - { { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" } - { { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" } - { { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" } - { { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" } - { { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" } - { { $vocab-link "globs" } " - simple Unix shell-style glob patterns" } - { { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" } - { { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" } - { { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" } - { { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" } - { { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" } - { { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } } - { { $vocab-link "webapps.planet" } " - add Atom feed generation" } -} -{ $heading "Factor 0.90" } -{ $subheading "Core" } -{ $list - { "New module system; see " { $link "vocabs.loader" } ". (Eduardo Cavazos)" } - { "Tuple constructors are defined differently now; see " { $link "tuple-constructors" } "." } - { "Mixin classes implemented; these are essentially extensible unions. See " { $link "mixins" } "." } - { "New " { $link float-array } " data type implements a space-efficient sequence of floats." } - { "Moved " { $link } ", " { $link delete-file } ", " { $link make-directory } ", " { $link delete-directory } " words from " { $snippet "libs/io" } " into the core, and fixed them to work on more platforms." } - { "New " { $link host-name } " word." } - { "The " { $link directory } " word now outputs an array of pairs, with the second element of each pair indicating if that entry is a subdirectory. This saves an unnecessary " { $link stat } " call when traversing directory hierarchies, which speeds things up." } - { "IPv6 is now supported, along with Unix domain sockets (the latter on Unix systems only). The stack effects of " { $link } " and " { $link } " have changed, since they now take generic address specifiers; see " { $link "network-streams" } "." } - { "The stage 2 bootstrap process is more flexible, and various subsystems such as help, tools and the UI can be omitted by supplying command line switches; see " { $link "bootstrap-cli-args" } "." } - { "The " { $snippet "-shell" } " command line switch has been replaced by a " { $snippet "-run" } " command line switch; see " { $link "standard-cli-args" } "." } - { "Variable usage inference has been removed; the " { $link infer } " word no longer reports this information." } - -} -{ $subheading "Tools" } -{ $list - { "Stand-alone image deployment; see " { $link "tools.deploy" } "." } - { "Stand-alone application bundle deployment on Mac OS X; see " { $vocab-link "tools.deploy.app" } "." } - { "New vocabulary browser tool in the UI." } - { "New profiler tool in the UI." } -} -{ $subheading "Extras" } -"Most existing libraries were improved when ported to the new module system; the most notable changes include:" -{ $list - { { $vocab-link "asn1" } ": ASN1 parser and writer. (Elie Chaftari)" } - { { $vocab-link "benchmark" } ": new set of benchmarks." } - { { $vocab-link "cfdg" } ": Context-free design grammar implementation; see " { $url "http://www.chriscoyne.com/cfdg/" } ". (Eduardo Cavazos)" } - { { $vocab-link "cryptlib" } ": Cryptlib library binding. (Elie Chaftari)" } - { { $vocab-link "cryptlib.streams" } ": Streams which perform SSL encryption and decryption. (Matthew Willis)" } - { { $vocab-link "hints" } ": Give type specialization hints to the compiler." } - { { $vocab-link "inverse" } ": Invertible computation and concatenative pattern matching. (Daniel Ehrenberg)" } - { { $vocab-link "ldap" } ": OpenLDAP library binding. (Elie Chaftari)" } - { { $vocab-link "locals" } ": Efficient lexically scoped locals, closures, and local words." } - { { $vocab-link "mortar" } ": Experimental message-passing object system. (Eduardo Cavazos)" } - { { $vocab-link "openssl" } ": OpenSSL library binding. (Elie Chaftari)" } - { { $vocab-link "pack" } ": Utility for reading and writing binary data. (Doug Coleman)" } - { { $vocab-link "pdf" } ": Haru PDF library binding. (Elie Chaftari)" } - { { $vocab-link "qualified" } ": Refer to words from another vocabulary without adding the entire vocabulary to the search path. (Daniel Ehrenberg)" } - { { $vocab-link "roman" } ": Reading and writing Roman numerals. (Doug Coleman)" } - { { $vocab-link "scite" } ": SciTE editor integration. (Clemens Hofreither)" } - { { $vocab-link "smtp" } ": SMTP client with support for CRAM-MD5 authentication. (Elie Chaftari, Dirk Vleugels)" } - { { $vocab-link "tuple-arrays" } ": Space-efficient packed tuple arrays. (Daniel Ehrenberg)" } - { { $vocab-link "unicode" } ": major new functionality added. (Daniel Ehrenberg)" } -} -{ $subheading "Performance" } -{ $list - { "The " { $link curry } " word now runs in constant time, and curried quotations can be called from compiled code; this allows for abstractions and idioms which were previously impractical due to performance issues. In particular, words such as " { $snippet "each-with" } " and " { $snippet "map-with" } " are gone; " { $snippet "each-with" } " can now be written as " { $snippet "with each" } ", and similarly for other " { $snippet "-with" } " combinators." } - "Improved generational promotion strategy in garbage collector reduces the amount of junk which makes its way into tenured space, which in turn reduces the frequency of full garbage collections." - "Faster generic word dispatch and union membership testing." - { "Alien memory accessors (" { $link "reading-writing-memory" } ") are compiled as intrinsics where possible, which improves performance in code which iteroperates with C libraries." } -} -{ $subheading "Platforms" } -{ $list - "Networking support added for Windows CE. (Doug Coleman)" - "UDP/IP networking support added for all Windows platforms. (Doug Coleman)" - "Solaris/x86 fixes. (Samuel Tardieu)" - "Linux/AMD64 port works again." -} ; - { } related-words From 3694064f41fb79b51c09d22fc0bda84b6cb65d7b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 18:07:39 -0600 Subject: [PATCH 50/58] Better optimizer.debugger --- extra/optimizer/debugger/debugger.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index db65a678cf..3cbddf8296 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -4,7 +4,7 @@ USING: classes inference inference.dataflow io kernel kernel.private math.parser namespaces optimizer prettyprint prettyprint.backend sequences words arrays match macros assocs sequences.private optimizer.specializers generic -combinators sorting math ; +combinators sorting math quotations ; IN: optimizer.debugger ! A simple tool for turning dataflow IR into quotations, for @@ -67,7 +67,7 @@ M: #shuffle node>quot [ , ] [ >r drop t r> ] if* dup effect-str "#shuffle: " swap append comment, ; -: pushed-literals node-out-d [ value-literal ] map ; +: pushed-literals node-out-d [ value-literal literalize ] map ; M: #push node>quot nip pushed-literals % ; @@ -83,6 +83,7 @@ M: #call-label node>quot #call>quot ; M: #label node>quot [ + dup node-param literalize , dup #label-loop? "#loop: " "#label: " ? over node-param word-name append comment, ] 2keep From f9c76689d6c3e4b48360de0b24bdacced749e2b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 15 Feb 2008 18:07:56 -0600 Subject: [PATCH 51/58] #loop optimization fixes --- core/generator/generator.factor | 29 ++-- core/optimizer/control/control-tests.factor | 35 ++++- core/optimizer/control/control.factor | 143 +++++++++++++------- 3 files changed, 139 insertions(+), 68 deletions(-) mode change 100644 => 100755 core/optimizer/control/control-tests.factor diff --git a/core/generator/generator.factor b/core/generator/generator.factor index e6a6226afa..3514947e3d 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -26,7 +26,7 @@ SYMBOL: compiling-word SYMBOL: compiling-label -SYMBOL: compiling-loop? +SYMBOL: compiling-loops ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start @@ -34,7 +34,7 @@ SYMBOL: current-label-start : compiled-stack-traces? ( -- ? ) 36 getenv ; : begin-compiling ( word label -- ) - compiling-loop? off + H{ } clone compiling-loops set compiling-label set compiling-word set compiled-stack-traces? @@ -94,8 +94,8 @@ M: node generate-node drop iterate-next ; : generate-call ( label -- next ) dup maybe-compile end-basic-block - dup compiling-label get eq? compiling-loop? get and [ - drop current-label-start get %jump-label f + dup compiling-loops get at [ + %jump-label f ] [ tail-call? [ %jump f @@ -104,7 +104,7 @@ M: node generate-node drop iterate-next ; %call iterate-next ] if - ] if ; + ] ?if ; ! #label M: #label generate-node @@ -113,17 +113,13 @@ M: #label generate-node r> ; ! #loop +: compiling-loop ( word -- ) +