steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Bootstrap performance improvement and assorted cleanups

release
slava 2006-05-10 06:18:25 +00:00
parent a842703e2f
commit fd8a3062e3
12 changed files with 96 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -111,7 +111,7 @@ macosx.app:
cp -R fonts/*.ttf $(BUNDLE)/Contents/Resources/fonts/
chmod +x cp_dir
find doc library contrib \( -name '*.factor' \
find doc library contrib examples \( -name '*.factor' \
-o -name '*.facts' \
-o -name '*.txt' \
-o -name '*.html' \

2
TODO.FACTOR.txt
View File

@ -3,7 +3,7 @@ should fix in 0.82:
- clean up fp-scratch
- intrinsic fixnum>float float>fixnum
- update amd64 backend
- float= on powerpc doesn't consider nans equal
- amd64 %box-struct
- when generating a 32-bit image on a 64-bit system, large numbers which should
be bignums become fixnums

19
library/bootstrap/boot-stage2.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler help io io-internals kernel
USING: compiler generic help io io-internals kernel
kernel-internals lists math memory namespaces optimizer parser
sequences sequences-internals words ;
@ -23,15 +23,14 @@ H{ } clone help-graph set-global xref-articles
"Compiling base..." print flush
\ slot \ set-slot [ usage ] 2apply append
[ try-compile ] each
\ + compile
\ = compile
{ "kernel" "sequences" "assembler" } compile-vocabs
"Compiling system..." print flush
compile-all
[
\ + compile
\ = compile
{ "kernel" "sequences" "assembler" } compile-vocabs
"Compiling system..." print flush
compile-all
] with-class<cache
terpri
"Unless you're working on the compiler, ignore the errors above." print

7
library/compiler/compiler.factor
View File

@ -6,11 +6,8 @@ namespaces optimizer prettyprint sequences test words ;
: (compile) ( word -- )
[
[
dup specialized-def dataflow optimize generate
] keep
] benchmark nip
"compile-time" set-word-prop ;
[ dup specialized-def dataflow optimize generate ] keep
] benchmark nip "compile-time" set-word-prop ;
: inform-compile ( word -- ) "Compiling " write . flush ;

15
library/compiler/inference/dataflow.factor
View File

@ -31,6 +31,7 @@ M: node = eq? ;
: param-node ( label) { } { } { } { } ;
: in-node ( inputs) >r f r> { } { } { } ;
: out-node ( outputs) >r f { } r> { } { } ;
: meta-d-node meta-d get clone in-node ;
: d-tail ( n -- list ) meta-d get tail* ;
: r-tail ( n -- list ) meta-r get tail* ;
@ -43,7 +44,8 @@ C: #label make-node ;
TUPLE: #entry ;
C: #entry make-node ;
: #entry ( -- node ) meta-d get clone in-node <#entry> ;
: #entry ( -- node ) meta-d-node <#entry> ;
TUPLE: #call ;
C: #call make-node ;
@ -55,7 +57,7 @@ C: #call-label make-node ;
TUPLE: #push ;
C: #push make-node ;
: #push ( outputs -- node ) d-tail out-node <#push> ;
: #push ( -- node ) peek-d out-node <#push> ;
: >#push< ( node -- seq ) node-out-d [ value-literal ] map ;
TUPLE: #shuffle ;
@ -64,23 +66,22 @@ C: #shuffle make-node ;
TUPLE: #values ;
C: #values make-node ;
: #values ( -- node ) meta-d get clone in-node <#values> ;
: #values ( -- node ) meta-d-node <#values> ;
TUPLE: #return ;
C: #return make-node ;
: #return ( label -- node )
#! The parameter is the label we are returning from, or if
#! f, this is a top-level return.
meta-d get clone in-node <#return>
[ set-node-param ] keep ;
meta-d-node <#return> [ set-node-param ] keep ;
TUPLE: #if ;
C: #if make-node ;
: #if ( in -- node ) 1 d-tail in-node <#if> ;
: #if ( in -- node ) peek-d in-node <#if> ;
TUPLE: #dispatch ;
C: #dispatch make-node ;
: #dispatch ( in -- node ) 1 d-tail in-node <#dispatch> ;
: #dispatch ( in -- node ) peek-d in-node <#dispatch> ;
TUPLE: #merge ;
C: #merge make-node ;

2
library/compiler/inference/inference.factor
View File

@ -76,7 +76,7 @@ GENERIC: apply-object
: apply-literal ( obj -- )
#! Literals are annotated with the current recursive
#! state.
<value> push-d 1 #push node, ;
<value> push-d #push node, ;
M: object apply-object apply-literal ;

2
library/compiler/inference/words.factor
View File

@ -104,7 +104,7 @@ M: #call-label collect-recursion* ( label node -- )
: infer-compound ( word base-case -- terminates? effect )
#! Infer a word's stack effect in a separate inferencer
#! instance. Outputs a boolean if the word terminates
#! instance. Outputs a true boolean if the word terminates
#! control flow by throwing an exception or restoring a
#! continuation.
[

19
library/compiler/optimizer/inline-methods.factor
View File

@ -66,26 +66,9 @@ kernel-internals lists math namespaces sequences words ;
: math-both-known? ( word left right -- ? )
math-class-max specific-method ;
: max-tag ( class -- n ) types peek 1+ num-tags min ;
: left-partial-math ( word left right -- quot/t )
#! The left type is known; dispatch on right
\ dup swap max-tag
[ >r 2dup r> math-method ] math-vtable* 2nip ;
: right-partial-math ( word left right -- quot/t )
#! The right type is known; dispatch on left
\ over rot max-tag
[ >r 2dup r> swap math-method ] math-vtable* 2nip ;
: will-inline-math-method ( word left right -- quot/t )
#! t indicates failure
{
{ [ 3dup math-both-known? ] [ math-method ] }
! { [ 3dup drop specific-method ] [ left-partial-math ] }
! { [ 3dup nip specific-method ] [ right-partial-math ] }
{ [ t ] [ 3drop t ] }
} cond ;
3dup math-both-known? [ math-method ] [ 3drop t ] if ;
: inline-math-method ( #call -- node )
dup node-param over 1 node-class# pick 0 node-class#

36
library/generic/generic.factor
View File

@ -1,10 +1,14 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: generic
USING: arrays errors hashtables kernel kernel-internals lists
namespaces parser sequences strings words vectors math
math-internals ;
: class? ( word -- ? ) "class" word-prop ;
: classes ( -- list ) [ class? ] word-subset ;
SYMBOL: typemap
SYMBOL: builtins
@ -41,19 +45,19 @@ SYMBOL: builtins
: types ( class -- types )
[ (types) ] make-hash hash-keys natural-sort ;
DEFER: class<
DEFER: (class<)
: superclass< ( cls1 cls2 -- ? )
>r superclass r> 2dup and [ class< ] [ 2drop f ] if ;
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
: union-class< ( cls1 cls2 -- ? )
>r flatten-class r> flatten-class hash-keys swap
[ drop swap [ class< ] contains-with? ] hash-all-with? ;
[ drop swap [ (class<) ] contains-with? ] hash-all-with? ;
: class-empty? ( class -- ? )
members dup [ empty? ] when ;
: class< ( cls1 cls2 -- ? )
: (class<) ( cls1 cls2 -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over class-empty? ] [ 2drop t ] }
@ -62,6 +66,21 @@ DEFER: class<
{ [ t ] [ union-class< ] }
} cond ;
SYMBOL: class<cache
: class< ( cls1 cls2 -- ? )
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
: smaller-classes ( class -- )
classes [ swap (class<) ] subset-with ;
: make-class<cache ( -- hash )
classes [ dup smaller-classes [ dup ] map>hash ] map>hash ;
: with-class<cache ( quot -- )
[ make-class<cache class<cache set call ] with-scope ;
inline
: class-compare ( cls1 cls2 -- -1/0/1 )
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
@ -80,8 +99,6 @@ M: generic definer drop \ G: ;
: make-generic ( word -- )
dup dup "combination" word-prop call define-compound ;
: class? ( word -- ? ) "class" word-prop ;
: check-method ( class generic -- )
dup generic? [
dup word-name " is not a generic word" append throw
@ -146,13 +163,12 @@ M: generic definer drop \ G: ;
: define-class ( class -- )
dup t "class" set-word-prop
dup H{ } clone "class<" set-word-prop
dup flatten-class typemap get set-hash ;
: implementors ( class -- list )
[ "methods" word-prop ?hash* nip ] word-subset-with ;
: classes ( -- list ) [ class? ] word-subset ;
! Predicate classes for generalized predicate dispatch.
: define-predicate-class ( class predicate definition -- )
pick define-class

23
library/generic/tuple.factor
View File

@ -1,11 +1,18 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
USING: arrays errors hashtables kernel lists math namespaces parser sequences sequences-internals strings vectors words ;
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: generic
USING: arrays errors hashtables kernel kernel-internals lists
math namespaces parser sequences sequences-internals strings
vectors words ;
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
: class-tuple ( object -- class )
dup tuple? [ 2 slot ] [ drop f ] if ; inline
IN: kernel-internals
: tuple= ( tuple tuple -- ? )
2dup [ array-capacity ] 2apply number= [
dup array-capacity
@ -15,14 +22,10 @@ USING: arrays errors hashtables kernel lists math namespaces parser sequences se
] if ; inline
: tuple-hashcode ( n tuple -- n )
dup class-tuple hashcode >r >r 1- r>
4 slot hashcode* r> bitxor ;
dup class hashcode >r >r 1- r> 4 slot hashcode* r> bitxor ;
IN: generic
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
: tuple-predicate ( word -- )
dup predicate-word
[ \ class-tuple , over literalize , \ eq? , ] [ ] make
@ -80,7 +83,7 @@ M: tuple clone ( tuple -- tuple )
M: tuple hashcode* ( n tuple -- n )
{
{ [ over 0 <= ] [ 2drop 0 ] }
{ [ dup array-capacity 2 <= ] [ nip class-tuple hashcode ] }
{ [ dup array-capacity 2 <= ] [ nip class hashcode ] }
{ [ t ] [ tuple-hashcode ] }
} cond ;

57
library/test/generic.factor
View File

@ -69,34 +69,39 @@ M: very-funny gooey sq ;
[ cons ] [ [ 1 2 ] class ] unit-test
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
: class<tests
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ list \ general-list class< ] unit-test
[ t ] [ \ list \ object class< ] unit-test
[ t ] [ \ null \ list class< ] unit-test
[ t ] [ \ generic \ compound class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test
[ f ] [ \ cons \ list class< ] unit-test
[ f ] [ \ list \ cons class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test ;
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ list \ general-list class< ] unit-test
[ t ] [ \ list \ object class< ] unit-test
[ t ] [ \ null \ list class< ] unit-test
class<tests
[ t ] [ \ generic \ compound class< ] unit-test
[ f ] [ \ compound \ generic class< ] unit-test
[ f ] [ \ cons \ list class< ] unit-test
[ f ] [ \ list \ cons class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
[ class<tests ] with-class<cache
PREDICATE: word no-docs "documentation" word-prop not ;

2
library/tools/interpreter.factor
View File

@ -12,9 +12,11 @@ namespaces prettyprint sequences strings vectors words ;
SYMBOL: meta-r
: push-r meta-r get push ;
: pop-r meta-r get pop ;
: peek-r meta-r get peek ;
SYMBOL: meta-d
: push-d meta-d get push ;
: pop-d meta-d get pop ;
: peek-d meta-d get peek ;
SYMBOL: meta-n
SYMBOL: meta-c