Merge branch 'master' of git://factorcode.org/git/factor into unicode
Conflicts: extra/benchmark/sockets/sockets.factordb4
Daniel Ehrenberg
commit
4c9ef7946d
|
|
@ -116,16 +116,18 @@ HELP: method-spec
|
|||
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
|
||||
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
|
||||
|
||||
HELP: method-body
|
||||
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
|
||||
|
||||
HELP: method
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." }
|
||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." } ;
|
||||
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||
{ $description "Creates a new method." } ;
|
||||
|
||||
HELP: methods
|
||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||
|
|
|
|||
|
|
@ -33,8 +33,6 @@ M: generic definition drop f ;
|
|||
dup { "unannotated-def" } reset-props
|
||||
dup dup "combination" word-prop perform-combination define ;
|
||||
|
||||
TUPLE: method word def specializer generic loc ;
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
|
|
@ -47,7 +45,7 @@ PREDICATE: pair method-spec
|
|||
: methods ( word -- assoc )
|
||||
"methods" word-prop
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-word ] curry { } map>assoc ;
|
||||
[ dupd at ] curry { } map>assoc ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
@ -63,29 +61,33 @@ TUPLE: check-method class generic ;
|
|||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot word combination -- quot )
|
||||
: make-method-def ( quot class generic -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method" word-prop >boolean ;
|
||||
PREDICATE: word method-body "method-def" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method" word-prop method-generic stack-effect ;
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
method-word-name f <word>
|
||||
dup rot define
|
||||
dup xref ;
|
||||
: method-word-props ( quot class generic -- assoc )
|
||||
[
|
||||
"method-generic" set
|
||||
"method-class" set
|
||||
"method-def" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
: <method> ( quot class generic -- word )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "method" set-word-prop ;
|
||||
[ make-method-def ] 3keep
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
tuck set-word-props
|
||||
dup rot define ;
|
||||
|
||||
: redefine-method ( quot class generic -- )
|
||||
[ method set-method-def ] 3keep
|
||||
[ method swap "method-def" set-word-prop ] 3keep
|
||||
[ make-method-def ] 2keep
|
||||
method method-word swap define ;
|
||||
method swap define ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
|
|
@ -102,21 +104,22 @@ M: method-body stack-effect
|
|||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method [ method-word ] [ second ] ?if where ;
|
||||
dup first2 method [ ] [ second ] ?if where ;
|
||||
|
||||
M: method-spec set-where
|
||||
first2 method method-word set-where ;
|
||||
first2 method set-where ;
|
||||
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
first2 method dup
|
||||
[ "method-def" word-prop ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget-word ] [ drop ] if ;
|
||||
[ forget-word ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
|
|
@ -125,11 +128,11 @@ M: method-body definer
|
|||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method" word-prop method-def ;
|
||||
"method-def" word-prop ;
|
||||
|
||||
M: method-body forget*
|
||||
"method" word-prop
|
||||
{ method-specializer method-generic } get-slots
|
||||
dup "method-class" word-prop
|
||||
swap "method-generic" word-prop
|
||||
forget-method ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
|
|
@ -168,8 +171,7 @@ M: word subwords drop f ;
|
|||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add
|
||||
[ method-word ] map ;
|
||||
swap "default-method" word-prop add ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
|
|||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ method-word word-def ]
|
||||
[ word-def ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
"default-method" word-prop method-word
|
||||
"default-method" word-prop
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: method-alist>quot ( alist base-class -- quot )
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ IN: inference.backend
|
|||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "method" word-prop
|
||||
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
|
||||
dup "method-generic" word-prop swap or "inline" word-prop ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
|
|
|
|||
|
|
@ -1,208 +1,208 @@
|
|||
! 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 kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
[ swap set-node-history ] curry each-node ;
|
||||
|
||||
: inlining-quot ( node quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
dup rot infer-classes/node ;
|
||||
|
||||
: splice-quot ( #call quot history -- node )
|
||||
#! Must add history *before* splicing in, otherwise
|
||||
#! the rest of the IR will also remember the history
|
||||
pick node-history append
|
||||
>r dupd inlining-quot dup r> remember-inlining
|
||||
tuck splice-node ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! heuristic: { ... } declare comes up in method bodies
|
||||
! and we don't care about it
|
||||
{ [ dup \ declare eq? ] [ drop -2 ] }
|
||||
! recursive
|
||||
{ [ dup get ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
} cond ;
|
||||
|
||||
: (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 ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
2dup dispatching-class dup [
|
||||
over +inlined+ depends-on
|
||||
swap method method-word 1quotation f splice-quot
|
||||
] [
|
||||
3drop t
|
||||
] if ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2 3dup math-both-known?
|
||||
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
|
||||
|
||||
: 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 <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot f 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 <repetition> 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 [ f 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 ;
|
||||
|
||||
: splice-word-def ( #call word -- node )
|
||||
dup +inlined+ depends-on
|
||||
dup word-def swap 1array splice-quot ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param over node-history memq? [
|
||||
drop t
|
||||
] [
|
||||
dup node-param splice-word-def
|
||||
] if ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 10 <= ] [ 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 ;
|
||||
! 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 kernel.private ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
[ swap set-node-history ] curry each-node ;
|
||||
|
||||
: inlining-quot ( node quot -- node )
|
||||
over node-in-d dataflow-with
|
||||
dup rot infer-classes/node ;
|
||||
|
||||
: splice-quot ( #call quot history -- node )
|
||||
#! Must add history *before* splicing in, otherwise
|
||||
#! the rest of the IR will also remember the history
|
||||
pick node-history append
|
||||
>r dupd inlining-quot dup r> remember-inlining
|
||||
tuck splice-node ;
|
||||
|
||||
! A heuristic to avoid excessive inlining
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! heuristic: { ... } declare comes up in method bodies
|
||||
! and we don't care about it
|
||||
{ [ dup \ declare eq? ] [ drop -2 ] }
|
||||
! recursive
|
||||
{ [ dup get ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
} cond ;
|
||||
|
||||
: (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 ;
|
||||
|
||||
! Single dispatch method inlining optimization
|
||||
: specific-method ( class word -- class ) order min-class ;
|
||||
|
||||
: node-class# ( node n -- class )
|
||||
over node-in-d <reversed> ?nth node-class ;
|
||||
|
||||
: dispatching-class ( node word -- class )
|
||||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
2dup dispatching-class dup [
|
||||
over +inlined+ depends-on
|
||||
swap method 1quotation f splice-quot
|
||||
] [
|
||||
3drop t
|
||||
] if ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: math-both-known? ( word left right -- ? )
|
||||
math-class-max swap specific-method ;
|
||||
|
||||
: inline-math-method ( #call word -- node )
|
||||
over node-input-classes first2 3dup math-both-known?
|
||||
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
|
||||
|
||||
: 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 <repetition>
|
||||
r> [ literalize ] map append >quotation ;
|
||||
|
||||
: inline-literals ( node literals -- node )
|
||||
#! Make #shuffle -> #push -> #return -> successor
|
||||
dupd literal-quot f 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 <repetition> 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 [ f 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 ;
|
||||
|
||||
: splice-word-def ( #call word -- node )
|
||||
dup +inlined+ depends-on
|
||||
dup word-def swap 1array splice-quot ;
|
||||
|
||||
: optimistic-inline ( #call -- node )
|
||||
dup node-param over node-history memq? [
|
||||
drop t
|
||||
] [
|
||||
dup node-param splice-word-def
|
||||
] if ;
|
||||
|
||||
: method-body-inline? ( #call -- ? )
|
||||
node-param dup method-body?
|
||||
[ flat-length 10 <= ] [ 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 ;
|
||||
|
|
|
|||
|
|
@ -1,378 +1,378 @@
|
|||
USING: arrays compiler.units 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 namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz compiled? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
"not a fixnum"
|
||||
] if ;
|
||||
|
||||
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
|
||||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] if ;
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
||||
! regression
|
||||
: (double-recursion) ( start end -- )
|
||||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
||||
[ 0 ] [ 10 double-label-2 ] unit-test
|
||||
|
||||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
|
||||
: test-2 ( -- ) 5 test-1 ;
|
||||
|
||||
[ f ] [ f test-2 ] unit-test
|
||||
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
||||
[ 10 ] [ branch-fold-regression-1 ] unit-test
|
||||
|
||||
! another regression
|
||||
: constant-branch-fold-0 "hey" ; foldable
|
||||
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
|
||||
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! another regression
|
||||
: foo f ;
|
||||
: bar foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression compiled? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ reversed ] [ reversed \ foozul specific-method ] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 f ; foldable
|
||||
: constant-fold-3 4 ; foldable
|
||||
|
||||
[ f t ] [
|
||||
[ constant-fold-2 constant-fold-3 4 = ] compile-call
|
||||
] unit-test
|
||||
|
||||
: constant-fold-4 f ; foldable
|
||||
: constant-fold-5 f ; foldable
|
||||
|
||||
[ f ] [
|
||||
[ constant-fold-4 constant-fold-5 or ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 5 [ dup < ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
|
||||
[ f ] [ 5 [ dup > ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup = ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
|
||||
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
|
||||
|
||||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
10 20 >vector <flat-slice>
|
||||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method method-word flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ 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
|
||||
|
||||
: 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
|
||||
|
||||
! 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
|
||||
|
||||
! Forgot a recursive inline check
|
||||
: recursive-inline-hang ( a -- a )
|
||||
dup array? [ recursive-inline-hang ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang array ;
|
||||
|
||||
: recursive-inline-hang-1
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
: recursive-inline-hang-2 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-3 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-2 array ;
|
||||
|
||||
: recursive-inline-hang-3 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-2 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
|
||||
USING: arrays compiler.units 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 namespaces hints ;
|
||||
IN: optimizer.tests
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz compiled? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
"not a fixnum"
|
||||
] if ;
|
||||
|
||||
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
|
||||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] if ;
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
||||
! regression
|
||||
: (double-recursion) ( start end -- )
|
||||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
||||
[ 0 ] [ 10 double-label-2 ] unit-test
|
||||
|
||||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
|
||||
: test-2 ( -- ) 5 test-1 ;
|
||||
|
||||
[ f ] [ f test-2 ] unit-test
|
||||
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
||||
[ 10 ] [ branch-fold-regression-1 ] unit-test
|
||||
|
||||
! another regression
|
||||
: constant-branch-fold-0 "hey" ; foldable
|
||||
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
|
||||
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! another regression
|
||||
: foo f ;
|
||||
: bar foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression compiled? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ reversed ] [ reversed \ foozul specific-method ] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 f ; foldable
|
||||
: constant-fold-3 4 ; foldable
|
||||
|
||||
[ f t ] [
|
||||
[ constant-fold-2 constant-fold-3 4 = ] compile-call
|
||||
] unit-test
|
||||
|
||||
: constant-fold-4 f ; foldable
|
||||
: constant-fold-5 f ; foldable
|
||||
|
||||
[ f ] [
|
||||
[ constant-fold-4 constant-fold-5 or ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 5 [ dup < ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
|
||||
[ f ] [ 5 [ dup > ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup = ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
|
||||
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
|
||||
|
||||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
10 20 >vector <flat-slice>
|
||||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ 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
|
||||
|
||||
: 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
|
||||
|
||||
! 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
|
||||
|
||||
! Forgot a recursive inline check
|
||||
: recursive-inline-hang ( a -- a )
|
||||
dup array? [ recursive-inline-hang ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang array ;
|
||||
|
||||
: recursive-inline-hang-1
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
: recursive-inline-hang-2 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-3 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-2 array ;
|
||||
|
||||
: recursive-inline-hang-3 ( a -- a )
|
||||
dup array? [ recursive-inline-hang-2 ] when ;
|
||||
|
||||
HINTS: recursive-inline-hang-3 array ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -175,10 +175,10 @@ M: method-spec synopsis*
|
|||
dup definer. [ pprint-word ] each ;
|
||||
|
||||
M: method-body synopsis*
|
||||
dup definer.
|
||||
"method" word-prop dup
|
||||
method-specializer pprint*
|
||||
method-generic pprint* ;
|
||||
dup dup
|
||||
definer.
|
||||
"method-class" word-prop pprint*
|
||||
"method-generic" word-prop pprint* ;
|
||||
|
||||
M: mixin-instance synopsis*
|
||||
dup definer.
|
||||
|
|
@ -269,7 +269,7 @@ M: builtin-class see-class*
|
|||
|
||||
: see-implementors ( class -- seq )
|
||||
dup implementors
|
||||
[ method method-word ] with map
|
||||
[ method ] with map
|
||||
natural-sort ;
|
||||
|
||||
: see-class ( class -- )
|
||||
|
|
@ -280,9 +280,7 @@ M: builtin-class see-class*
|
|||
] when drop ;
|
||||
|
||||
: see-methods ( generic -- seq )
|
||||
"methods" word-prop
|
||||
[ nip method-word ] { } assoc>map
|
||||
natural-sort ;
|
||||
"methods" word-prop values natural-sort ;
|
||||
|
||||
M: word see
|
||||
dup see-class
|
||||
|
|
|
|||
|
|
@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
|
|||
|
||||
M: f set-vocab-docs-loaded? 2drop ;
|
||||
|
||||
M: f vocab-help ;
|
||||
|
||||
: create-vocab ( name -- vocab )
|
||||
dictionary get [ <vocab> ] cache ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
|
|||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method" word-prop ] [ t ] }
|
||||
{ [ dup "method-definition" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -1,65 +1,58 @@
|
|||
USING: io.sockets io kernel math threads io.encodings.ascii
|
||||
debugger tools.time prettyprint concurrency.count-downs
|
||||
namespaces arrays continuations ;
|
||||
IN: benchmark.sockets
|
||||
|
||||
SYMBOL: counter
|
||||
|
||||
: number-of-requests 1 ;
|
||||
|
||||
: server-addr "127.0.0.1" 7777 <inet4> ;
|
||||
|
||||
: server-loop ( server -- )
|
||||
dup accept [
|
||||
[
|
||||
read1 CHAR: x = [
|
||||
"server" get dispose
|
||||
] [
|
||||
number-of-requests
|
||||
[ read1 write1 flush ] times
|
||||
counter get count-down
|
||||
] if
|
||||
] with-stream
|
||||
] curry "Client handler" spawn drop server-loop ;
|
||||
|
||||
: simple-server ( -- )
|
||||
[
|
||||
server-addr ascii <server> dup "server" set [
|
||||
server-loop
|
||||
] with-disposal
|
||||
] ignore-errors ;
|
||||
|
||||
: simple-client ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: b write1 flush
|
||||
number-of-requests
|
||||
[ CHAR: a dup write1 flush read1 assert= ] times
|
||||
counter get count-down
|
||||
] with-stream ;
|
||||
|
||||
: stop-server ( -- )
|
||||
server-addr <client> [
|
||||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: clients ( n -- )
|
||||
dup pprint " clients: " write [
|
||||
dup 2 * <count-down> counter set
|
||||
[ simple-server ] "Simple server" spawn drop
|
||||
yield yield
|
||||
[ [ simple-client ] "Simple client" spawn drop ] times
|
||||
counter get await
|
||||
stop-server
|
||||
yield yield
|
||||
] time ;
|
||||
|
||||
: socket-benchmarks
|
||||
10 clients
|
||||
20 clients
|
||||
40 clients ;
|
||||
! 80 clients
|
||||
! 160 clients
|
||||
! 320 clients
|
||||
! 640 clients ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
USING: io.sockets io kernel math threads
|
||||
debugger tools.time prettyprint concurrency.count-downs
|
||||
namespaces arrays continuations ;
|
||||
IN: benchmark.sockets
|
||||
|
||||
SYMBOL: counter
|
||||
|
||||
: number-of-requests 1 ;
|
||||
|
||||
: server-addr "127.0.0.1" 7777 <inet4> ;
|
||||
|
||||
: server-loop ( server -- )
|
||||
dup accept [
|
||||
[
|
||||
read1 CHAR: x = [
|
||||
"server" get dispose
|
||||
] [
|
||||
number-of-requests
|
||||
[ read1 write1 flush ] times
|
||||
counter get count-down
|
||||
] if
|
||||
] with-stream
|
||||
] curry "Client handler" spawn drop server-loop ;
|
||||
|
||||
: simple-server ( -- )
|
||||
[
|
||||
server-addr ascii <server> dup "server" set [
|
||||
server-loop
|
||||
] with-disposal
|
||||
] ignore-errors ;
|
||||
|
||||
: simple-client ( -- )
|
||||
server-addr ascii <client> [
|
||||
CHAR: b write1 flush
|
||||
number-of-requests
|
||||
[ CHAR: a dup write1 flush read1 assert= ] times
|
||||
counter get count-down
|
||||
] with-stream ;
|
||||
|
||||
: stop-server ( -- )
|
||||
server-addr ascii <client> [
|
||||
CHAR: x write1
|
||||
] with-stream ;
|
||||
|
||||
: clients ( n -- )
|
||||
dup pprint " clients: " write [
|
||||
dup 2 * <count-down> counter set
|
||||
[ simple-server ] "Simple server" spawn drop
|
||||
yield yield
|
||||
[ [ simple-client ] "Simple client" spawn drop ] times
|
||||
counter get await
|
||||
stop-server
|
||||
yield yield
|
||||
] time ;
|
||||
|
||||
: socket-benchmarks ;
|
||||
|
||||
MAIN: socket-benchmarks
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
|
|||
|
||||
: destination ( -- dest )
|
||||
upload-images-destination get
|
||||
"slava@/var/www/factorcode.org/newsite/images/latest/"
|
||||
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
|
||||
or ;
|
||||
|
||||
: checksums "checksums.txt" temp-file ;
|
||||
|
|
|
|||
|
|
@ -144,20 +144,32 @@ M: f print-element drop ;
|
|||
: $link ( element -- )
|
||||
first ($link) ;
|
||||
|
||||
: ($subsection) ( object -- )
|
||||
[ article-title ] keep >link write-object ;
|
||||
: ($long-link) ( object -- )
|
||||
dup article-title swap >link write-link ;
|
||||
|
||||
: $subsection ( element -- )
|
||||
: ($subsection) ( element quot -- )
|
||||
[
|
||||
subsection-style get [
|
||||
bullet get write bl
|
||||
first ($subsection)
|
||||
call
|
||||
] with-style
|
||||
] ($block) ;
|
||||
] ($block) ; inline
|
||||
|
||||
: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
|
||||
: $subsection ( element -- )
|
||||
[ first ($long-link) ] ($subsection) ;
|
||||
|
||||
: $vocab-link ( element -- ) first ($vocab-link) ;
|
||||
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
|
||||
|
||||
: $vocab-subsection ( element -- )
|
||||
[
|
||||
first2 dup vocab-help dup [
|
||||
2nip ($long-link)
|
||||
] [
|
||||
drop ($vocab-link)
|
||||
] if
|
||||
] ($subsection) ;
|
||||
|
||||
: $vocab-link ( element -- ) first dup ($vocab-link) ;
|
||||
|
||||
: $vocabulary ( element -- )
|
||||
first word-vocabulary [
|
||||
|
|
|
|||
|
|
@ -35,33 +35,43 @@ HELP: +environment-mode+
|
|||
HELP: +stdin+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard input is inherited" }
|
||||
{ { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +inherit+ } " - standard input is inherited from the current process" }
|
||||
{ { $link +closed+ } " - standard input is closed" }
|
||||
{ "a path name - standard input is read from the given file, which must exist" }
|
||||
{ "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stdout+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard output is inherited" }
|
||||
{ { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +inherit+ } " - standard output is inherited from the current process" }
|
||||
{ { $link +closed+ } " - standard output is closed" }
|
||||
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" }
|
||||
{ "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +stderr+
|
||||
{ $description "Launch descriptor key. Must equal one of the following:"
|
||||
{ $list
|
||||
{ { $link f } " - standard error is inherited" }
|
||||
{ { $link f } " - standard error is inherited from the current process" }
|
||||
{ { $link +inherit+ } " - same as above" }
|
||||
{ { $link +stdout+ } " - standard error is merged with standard output" }
|
||||
{ { $link +closed+ } " - standard error is closed" }
|
||||
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" }
|
||||
{ "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: +closed+
|
||||
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
|
||||
|
||||
HELP: +inherit+
|
||||
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
|
||||
|
||||
HELP: +prepend-environment+
|
||||
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,18 +1,38 @@
|
|||
! 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 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 strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend
|
||||
combinators ;
|
||||
combinators shuffle ;
|
||||
IN: io.windows.nt.launcher
|
||||
|
||||
: duplicate-handle ( handle -- handle' )
|
||||
GetCurrentProcess ! source process
|
||||
swap ! handle
|
||||
GetCurrentProcess ! target process
|
||||
f <void*> [ ! target handle
|
||||
DUPLICATE_SAME_ACCESS ! desired access
|
||||
TRUE ! inherit handle
|
||||
DUPLICATE_CLOSE_SOURCE ! options
|
||||
DuplicateHandle win32-error=0/f
|
||||
] keep *void* ;
|
||||
|
||||
! 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
|
||||
: redirect-default ( default obj access-mode create-mode -- handle )
|
||||
3drop ;
|
||||
|
||||
: redirect-inherit ( default obj access-mode create-mode -- handle )
|
||||
4drop f ;
|
||||
|
||||
: redirect-closed ( default obj access-mode create-mode -- handle )
|
||||
drop 2nip null-pipe ;
|
||||
|
||||
: redirect-file ( default path access-mode create-mode -- handle )
|
||||
>r >r >r drop r>
|
||||
normalize-pathname
|
||||
r> ! access-mode
|
||||
share-mode
|
||||
|
|
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
|
|||
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 ;
|
||||
|
||||
: redirect-stream ( default stream access-mode create-mode -- handle )
|
||||
2drop nip
|
||||
underlying-handle win32-file-handle
|
||||
duplicate-handle dup t set-inherit ;
|
||||
|
||||
: redirect ( default obj access-mode create-mode -- handle )
|
||||
{
|
||||
{ [ pick not ] [ redirect-default ] }
|
||||
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ t ] [ redirect-stream ] }
|
||||
} cond ;
|
||||
|
||||
: default-stdout ( args -- handle )
|
||||
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
|
||||
|
||||
: redirect-stdout ( args -- handle )
|
||||
default-stdout
|
||||
+stdout+ get
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_OUTPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: redirect-stderr ( args -- handle )
|
||||
+stderr+ get +stdout+ eq? [
|
||||
CreateProcess-args-lpStartupInfo
|
||||
STARTUPINFO-hStdOutput
|
||||
] [
|
||||
drop
|
||||
f
|
||||
+stderr+ get
|
||||
GENERIC_WRITE
|
||||
CREATE_ALWAYS
|
||||
redirect
|
||||
STD_ERROR_HANDLE GetStdHandle or
|
||||
] if ;
|
||||
|
||||
: default-stdin ( args -- handle )
|
||||
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
|
||||
|
||||
: redirect-stdin ( args -- handle )
|
||||
default-stdin
|
||||
+stdin+ get
|
||||
GENERIC_READ
|
||||
OPEN_EXISTING
|
||||
redirect
|
||||
STD_INPUT_HANDLE GetStdHandle or ;
|
||||
|
||||
: add-pipe-dtors ( pipe -- )
|
||||
dup
|
||||
pipe-in close-later
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ M: win32-file close-handle ( handle -- )
|
|||
: open-file ( path access-mode create-mode flags -- handle )
|
||||
[
|
||||
>r >r >r normalize-pathname r>
|
||||
share-mode f r> r> CreateFile-flags f CreateFile
|
||||
share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
|
||||
dup invalid-handle? dup close-later
|
||||
dup add-completion
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
|
|||
! are unified
|
||||
: create-method ( class generic -- method )
|
||||
2dup method dup
|
||||
[ 2nip method-word ]
|
||||
[ 2nip ]
|
||||
[ drop 2dup [ ] -rot define-method create-method ] if ;
|
||||
|
||||
: CREATE-METHOD ( -- class generic body )
|
||||
|
|
@ -369,14 +369,14 @@ M: lambda-method definition
|
|||
|
||||
: method-stack-effect
|
||||
dup "lambda" word-prop lambda-vars
|
||||
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
|
||||
swap "method-generic" word-prop stack-effect
|
||||
dup [ effect-out ] when
|
||||
<effect> ;
|
||||
|
||||
M: lambda-method synopsis*
|
||||
dup definer.
|
||||
dup "method" word-prop dup
|
||||
method-specializer pprint*
|
||||
method-generic pprint*
|
||||
dup dup definer.
|
||||
"method-specializer" word-prop pprint*
|
||||
"method-generic" word-prop pprint*
|
||||
method-stack-effect effect>string comment. ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ HELP: schedule-insomniac
|
|||
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
|
||||
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
|
||||
|
||||
ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
|
||||
ARTICLE: "logging.insomniac" "Automated log analysis"
|
||||
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
|
||||
$nl
|
||||
"Required configuration parameters:"
|
||||
|
|
|
|||
|
|
@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
|
|||
{ $subsection "logging.levels" }
|
||||
{ $subsection "logging.messages" }
|
||||
{ $subsection "logging.rotation" }
|
||||
{ $subsection "logging.parser" }
|
||||
{ $subsection "logging.analysis" }
|
||||
{ $subsection "logging.insomniac" }
|
||||
{ $vocab-subsection "Log file parser" "logging.parser" }
|
||||
{ $vocab-subsection "Log analysis" "logging.analysis" }
|
||||
{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
|
||||
{ $subsection "logging.server" } ;
|
||||
|
||||
ABOUT: "logging"
|
||||
|
|
|
|||
|
|
@ -29,9 +29,8 @@ M: string (profile.)
|
|||
dup <vocab-profile> write-object ;
|
||||
|
||||
M: method-body (profile.)
|
||||
"method" word-prop
|
||||
dup method-specializer over method-generic 2array synopsis
|
||||
swap method-generic <usage-profile> write-object ;
|
||||
dup synopsis swap "method-generic" word-prop
|
||||
<usage-profile> write-object ;
|
||||
|
||||
: counter. ( obj n -- )
|
||||
[
|
||||
|
|
|
|||
Loading…
Reference in New Issue