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

started linearizer, and new compiler framework

cvs
Slava Pestov 2004-12-02 00:48:08 +00:00
parent 7308c11b18
commit ec849514bb
12 changed files with 568 additions and 376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,169 +1,174 @@
! :folding=indent:collapseFolds=1: ! :folding=indent:collapseFolds=1:
! $Id$ ! $Id$
! !
! Copyright (C) 2004 Slava Pestov. ! Copyright (C) 2004 Slava Pestov.
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met: ! modification, are permitted provided that the following conditions are met:
! !
! 1. Redistributions of source code must retain the above copyright notice, ! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer. ! this list of conditions and the following disclaimer.
! !
! 2. Redistributions in binary form must reproduce the above copyright notice, ! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation ! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution. ! and/or other materials provided with the distribution.
! !
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init IN: init
USE: combinators USE: combinators
USE: kernel USE: kernel
USE: lists USE: lists
USE: parser USE: parser
USE: stack USE: stack
USE: stdio USE: stdio
"Cold boot in progress..." print "Cold boot in progress..." print
[ [
"/version.factor" "/version.factor"
"/library/kernel.factor" "/library/kernel.factor"
"/library/stack.factor" "/library/stack.factor"
"/library/types.factor" "/library/types.factor"
"/library/math/math.factor" "/library/math/math.factor"
"/library/cons.factor" "/library/cons.factor"
"/library/combinators.factor" "/library/combinators.factor"
"/library/logic.factor" "/library/logic.factor"
"/library/vector-combinators.factor" "/library/vector-combinators.factor"
"/library/lists.factor" "/library/lists.factor"
"/library/assoc.factor" "/library/assoc.factor"
"/library/math/arithmetic.factor" "/library/math/arithmetic.factor"
"/library/math/math-combinators.factor" "/library/math/math-combinators.factor"
"/library/vectors.factor" "/library/vectors.factor"
"/library/strings.factor" "/library/strings.factor"
"/library/hashtables.factor" "/library/hashtables.factor"
"/library/namespaces.factor" "/library/namespaces.factor"
"/library/generic.factor" "/library/generic.factor"
"/library/math/namespace-math.factor" "/library/math/namespace-math.factor"
"/library/list-namespaces.factor" "/library/list-namespaces.factor"
"/library/sbuf.factor" "/library/sbuf.factor"
"/library/continuations.factor" "/library/continuations.factor"
"/library/errors.factor" "/library/errors.factor"
"/library/threads.factor" "/library/threads.factor"
"/library/io/stream.factor" "/library/io/stream.factor"
"/library/io/io-internals.factor" "/library/io/io-internals.factor"
"/library/io/stream-impl.factor" "/library/io/stream-impl.factor"
"/library/io/stdio.factor" "/library/io/stdio.factor"
"/library/words.factor" "/library/words.factor"
"/library/vocabularies.factor" "/library/vocabularies.factor"
"/library/syntax/parse-numbers.factor" "/library/syntax/parse-numbers.factor"
"/library/syntax/parser.factor" "/library/syntax/parser.factor"
"/library/syntax/parse-syntax.factor" "/library/syntax/parse-syntax.factor"
"/library/syntax/parse-stream.factor" "/library/syntax/parse-stream.factor"
"/library/math/generic.factor" "/library/math/generic.factor"
"/library/bootstrap/init.factor" "/library/bootstrap/init.factor"
"/library/format.factor" "/library/format.factor"
"/library/syntax/unparser.factor" "/library/syntax/unparser.factor"
"/library/io/presentation.factor" "/library/io/presentation.factor"
"/library/io/vocabulary-style.factor" "/library/io/vocabulary-style.factor"
"/library/syntax/prettyprint.factor" "/library/syntax/prettyprint.factor"
"/library/syntax/see.factor" "/library/syntax/see.factor"
"/library/tools/debugger.factor" "/library/tools/debugger.factor"
"/library/math/constants.factor" "/library/math/constants.factor"
"/library/math/pow.factor" "/library/math/pow.factor"
"/library/math/trig-hyp.factor" "/library/math/trig-hyp.factor"
"/library/math/arc-trig-hyp.factor" "/library/math/arc-trig-hyp.factor"
"/library/in-thread.factor" "/library/in-thread.factor"
"/library/io/network.factor" "/library/io/network.factor"
"/library/io/logging.factor" "/library/io/logging.factor"
"/library/random.factor" "/library/random.factor"
"/library/io/stdio-binary.factor" "/library/io/stdio-binary.factor"
"/library/io/files.factor" "/library/io/files.factor"
"/library/eval-catch.factor" "/library/eval-catch.factor"
"/library/tools/listener.factor" "/library/tools/listener.factor"
"/library/tools/inspector.factor" "/library/tools/inspector.factor"
"/library/tools/word-tools.factor" "/library/tools/word-tools.factor"
"/library/test/test.factor" "/library/test/test.factor"
"/library/io/ansi.factor" "/library/io/ansi.factor"
"/library/tools/telnetd.factor" "/library/tools/telnetd.factor"
"/library/tools/jedit-wire.factor" "/library/tools/jedit-wire.factor"
"/library/tools/profiler.factor" "/library/tools/profiler.factor"
"/library/tools/heap-stats.factor" "/library/tools/heap-stats.factor"
"/library/gensym.factor" "/library/gensym.factor"
"/library/tools/interpreter.factor" "/library/tools/interpreter.factor"
! Inference needs to know primitive stack effects at load time ! Inference needs to know primitive stack effects at load time
"/library/primitives.factor" "/library/primitives.factor"
"/library/inference/dataflow.factor" "/library/inference/dataflow.factor"
"/library/inference/inference.factor" "/library/inference/inference.factor"
"/library/inference/words.factor" "/library/inference/words.factor"
"/library/inference/branches.factor" "/library/inference/branches.factor"
"/library/inference/stack.factor" "/library/inference/stack.factor"
"/library/bootstrap/image.factor" "/library/compiler/linearizer.factor"
"/library/bootstrap/cross-compiler.factor" "/library/compiler/assembler.factor"
"/library/compiler/xt.factor"
"/library/httpd/url-encoding.factor" "/library/compiler/generator.factor"
"/library/httpd/html-tags.factor" "/library/compiler/compiler.factor"
"/library/httpd/html.factor"
"/library/httpd/http-common.factor" "/library/bootstrap/image.factor"
"/library/httpd/responder.factor" "/library/bootstrap/cross-compiler.factor"
"/library/httpd/httpd.factor"
"/library/httpd/file-responder.factor" "/library/httpd/url-encoding.factor"
"/library/httpd/inspect-responder.factor" "/library/httpd/html-tags.factor"
"/library/httpd/test-responder.factor" "/library/httpd/html.factor"
"/library/httpd/quit-responder.factor" "/library/httpd/http-common.factor"
"/library/httpd/resource-responder.factor" "/library/httpd/responder.factor"
"/library/httpd/default-responders.factor" "/library/httpd/httpd.factor"
"/library/httpd/file-responder.factor"
"/library/tools/jedit.factor" "/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor"
"/library/cli.factor" "/library/httpd/quit-responder.factor"
] [ "/library/httpd/resource-responder.factor"
dup print "/library/httpd/default-responders.factor"
run-resource
] each "/library/tools/jedit.factor"
cpu "x86" = [ "/library/cli.factor"
[ ] [
"/library/compiler/assembler.factor" dup print
"/library/compiler/assembly-x86.factor" run-resource
"/library/compiler/compiler-macros.factor" ] each
"/library/compiler/compiler.factor"
"/library/compiler/ifte.factor" cpu "x86" = [
"/library/compiler/generic.factor" [
"/library/compiler/stack.factor" "/library/compiler/assembly-x86.factor"
"/library/compiler/interpret-only.factor" "/library/compiler/generator-x86.factor"
"/library/compiler/alien-types.factor" ! "/library/compiler/compiler-macros.factor"
"/library/compiler/alien-macros.factor" ! "/library/compiler/ifte.factor"
"/library/compiler/alien.factor" ! "/library/compiler/generic.factor"
! "/library/compiler/stack.factor"
"/library/sdl/sdl.factor" ! "/library/compiler/interpret-only.factor"
"/library/sdl/sdl-video.factor" ! "/library/compiler/alien-types.factor"
"/library/sdl/sdl-event.factor" ! "/library/compiler/alien-macros.factor"
"/library/sdl/sdl-gfx.factor" ! "/library/compiler/alien.factor"
"/library/sdl/sdl-keysym.factor" !
"/library/sdl/sdl-utils.factor" ! "/library/sdl/sdl.factor"
"/library/sdl/hsv.factor" ! "/library/sdl/sdl-video.factor"
] [ ! "/library/sdl/sdl-event.factor"
dup print ! "/library/sdl/sdl-gfx.factor"
run-resource ! "/library/sdl/sdl-keysym.factor"
] each ! "/library/sdl/sdl-utils.factor"
] [ ! "/library/sdl/hsv.factor"
"/library/compiler/dummy-compiler.factor" dup print run-resource ] [
] ifte dup print
run-resource
"/library/bootstrap/init-stage2.factor" dup print run-resource ] each
] [
"/library/compiler/dummy-compiler.factor" dup print run-resource
] ifte
"/library/bootstrap/init-stage2.factor" dup print run-resource

188
library/compiler/compiler.factor
View File

@ -27,9 +27,12 @@
IN: compiler IN: compiler
USE: combinators USE: combinators
USE: dataflow
USE: errors USE: errors
USE: generator
USE: hashtables USE: hashtables
USE: kernel USE: kernel
USE: linearizer
USE: lists USE: lists
USE: logic USE: logic
USE: math USE: math
@ -43,175 +46,9 @@ USE: unparser
USE: vectors USE: vectors
USE: words USE: words
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
! sets the xt of each word in the hashtable to the value in the
! hastable.
!
! This has the advantage that we can compile a word before the
! words it depends on and perform a fixup later; among other
! things this enables mutually recursive words.
SYMBOL: compiled-xts
: save-xt ( word -- )
cell compile-aligned
compiled-offset swap compiled-xts acons@ ;
: commit-xt ( xt word -- )
dup t "compiled" set-word-property set-word-xt ;
: commit-xts ( -- )
compiled-xts get [ unswons commit-xt ] each
compiled-xts off ;
: compiled-xt ( word -- xt )
dup compiled-xts get assoc [ nip ] [ word-xt ] ifte* ;
! "deferred-xts" is a list of [ where word relative ] pairs; the
! xt of word when its done compiling will be written to the
! offset, relative to the offset.
SYMBOL: deferred-xts
! Words being compiled are consed onto this list. When a word
! is encountered that has not been previously compiled, it is
! consed onto this list. Compilation stops when the list is
! empty.
SYMBOL: compile-words
: defer-xt ( word where relative -- )
#! After word is compiled, put its XT at where, relative.
3list deferred-xts cons@ ;
: compiling? ( word -- ? )
#! A word that is compiling or already compiled will not be
#! added to the list of words to be compiled.
dup compiled? [
drop t
] [
dup compile-words get contains? [
drop t
] [
compiled-xts get assoc
] ifte
] ifte ;
: fixup-deferred-xt ( word where relative -- )
rot dup compiling? [
compiled-xt swap - swap set-compiled-cell
] [
"Not compiled: " swap word-name cat2 throw
] ifte ;
: fixup-deferred-xts ( -- )
deferred-xts get [
uncons uncons car fixup-deferred-xt
] each
deferred-xts off ;
: postpone-word ( word -- )
dup compiling? [ drop ] [ compile-words unique@ ] ifte ;
! During compilation, these two variables store pending
! literals. Literals are either consumed at compile-time by
! words with special compilation behavior, or otherwise they are
! compiled into code that pushes them.
SYMBOL: compile-datastack
SYMBOL: compile-callstack
: pop-literal ( -- obj )
compile-datastack get vector-pop ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
#! are compiled immediately. Everything else can be moved
#! by GC, and is indexed through a table.
dup fixnum? swap f eq? or ;
: compile-literal ( obj -- )
dup immediate? [
address LITERAL
] [
intern-literal [LITERAL]
] ifte ;
: commit-literals ( -- )
compile-datastack get
dup vector-empty? [
drop
] [
dup [ compile-literal ] vector-each
0 swap set-vector-length
] ifte ;
: postpone-literal ( obj -- )
#! Literals are not compiled immediately, so that words like
#! ifte with special compilation behavior can work.
compile-datastack get vector-push ;
: tail? ( -- ? )
compile-callstack get vector-empty? ;
: compile-simple-word ( word -- )
#! Compile a JMP at the end (tail call optimization)
dup postpone-word
commit-literals tail? [ JUMP ] [ CALL ] ifte
compiled-offset defer-xt ;
: compile-word ( word -- )
#! If a word has a compiling property, then it has special
#! compilation behavior.
dup "compiling" word-property dup [
nip call
] [
drop compile-simple-word
] ifte ;
: begin-compiling-quot ( quot -- )
compile-callstack get vector-push ;
: end-compiling-quot ( -- )
compile-callstack get vector-pop drop ;
: compiling ( quot -- )
#! Called on each iteration of compile-loop, with the
#! remaining quotation.
[
compile-callstack get
dup vector-length pred
swap set-vector-nth
] [
end-compiling-quot
] ifte* ;
: compile-atom ( obj -- )
dup word? [ compile-word ] [ postpone-literal ] ifte ;
: compile-loop ( quot -- )
[
uncons dup compiling swap compile-atom compile-loop
] when* ;
: compile-quot ( quot -- )
[
dup begin-compiling-quot compile-loop commit-literals
] when* ;
: with-compiler ( quot -- )
[
10 <vector> compile-datastack set
10 <vector> compile-callstack set
call
fixup-deferred-xts
commit-xts
] with-scope ;
: (compile) ( word -- ) : (compile) ( word -- )
#! Should be called inside the with-compiler scope. #! Should be called inside the with-compiler scope.
dup save-xt word-parameter compile-quot RET ; dup save-xt word-parameter dataflow linearize generate ;
: compile-postponed ( -- ) : compile-postponed ( -- )
compile-words get [ compile-words get [
@ -225,19 +62,4 @@ SYMBOL: compile-callstack
#! Compile the most recently defined word. #! Compile the most recently defined word.
word compile ; parsing word compile ; parsing
: cannot-compile ( word -- ) : compile-all ;
"verbose-compile" get [
"Cannot compile " write .
] [
drop
] ifte ;
: compile-all ( -- )
#! Compile all words.
[
dup "infer-effect" word-property [
[ compile ] [ [ cannot-compile ] when ] catch
] [
drop
] ifte
] each-word ;

100
library/compiler/generator-x86.factor Normal file
View File

@ -0,0 +1,100 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: generator
USE: alien
USE: combinators
USE: compiler
USE: dataflow
USE: errors
USE: kernel
USE: linearizer
USE: lists
USE: logic
USE: math
USE: namespaces
USE: stack
USE: strings
USE: words
: LITERAL ( cell -- )
#! Push literal on data stack.
4 ESI R+I
ESI I>[R] ;
: [LITERAL] ( cell -- )
#! Push complex literal on data stack by following an
#! indirect pointer.
4 ESI R+I
EAX [I]>R
EAX ESI R>[R] ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
#! are compiled immediately. Everything else can be moved
#! by GC, and is indexed through a table.
dup fixnum? swap f eq? or ;
: compile-literal ( obj -- )
dup immediate? [
address LITERAL
] [
intern-literal [LITERAL]
] ifte ;
: PUSH-DS ( -- )
#! Push contents of EAX onto datastack.
4 ESI R+I
EAX ESI R>[R] ;
: POP-DS ( -- )
#! Pop datastack, store pointer to datastack top in EAX.
ESI EAX [R]>R
4 ESI R-I ;
: SELF-CALL ( name -- )
#! Call named C function in Factor interpreter executable.
dlsym-self CALL JUMP-FIXUP ;
: TYPE ( -- )
#! Peek datastack, store type # in EAX.
ESI PUSH-[R]
"type_of" SELF-CALL
4 ESP R+I ;
: ARITHMETIC-TYPE ( -- )
#! Peek top two on datastack, store arithmetic type # in EAX.
ESI EAX R>R
EAX PUSH-[R]
4 EAX R-I
EAX PUSH-[R]
"arithmetic_type" SELF-CALL
8 ESP R+I ;
\ #push [ compile-literal ] "generator" set-word-property
\ #call [ CALL compiled-offset defer-xt ] "generator" set-word-property
\ #return [ drop RET ] "generator" set-word-property

51
library/compiler/generator.factor Normal file
View File

@ -0,0 +1,51 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: generator
USE: combinators
USE: compiler
USE: dataflow
USE: errors
USE: linearizer
USE: lists
USE: math
USE: namespaces
USE: stack
USE: strings
USE: words
: generate-node ( [ op | params ] -- )
#! Generate machine code for a node.
unswons dup "generator" word-property dup [
nip call
] [
"No generator" throw
] ifte ;
: generate ( linear -- )
#! Compile a word definition from linear IR.
[ generate-node ] each ;

88
library/compiler/linearizer.factor Normal file
View File

@ -0,0 +1,88 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: linearizer
USE: lists
USE: words
USE: stack
USE: namespaces
USE: dataflow
USE: combinators
! Linear IR nodes. This is in addition to the symbols already
! defined in dataflow vocab.
SYMBOL: #branch-t ( branch if top of stack is true )
SYMBOL: #branch ( unconditional branch )
SYMBOL: #label ( branch target )
SYMBOL: #jump ( tail-call )
SYMBOL: #return ( return to caller )
: linear, ( param op -- )
swons , ;
: >linear ( node -- )
#! Dataflow OPs have a linearizer word property. This
#! quotation is executed to convert the node into linear
#! form.
[ node-param get node-op get ] bind
dup "linearizer" word-property dup [
nip call
] [
drop linear,
] ifte ;
: (linearize) ( dataflow -- )
[ >linear ] each ;
: linearize ( dataflow -- linear )
#! Transform dataflow IR into linear IR. This strips out
#! stack flow information, flattens conditionals into
#! jumps and labels, and turns dataflow IR nodes into
#! lists where the first element is an operation, and the
#! rest is arguments.
[ (linearize) f #return linear, ] make-list ;
: <label> ( -- label )
gensym ;
: label, ( label -- )
#label linear, ;
: linearize-ifte ( param -- )
#! The parameter is a list of two lists, each one a dataflow
#! IR.
uncons car
<label> [
#branch-t linear,
(linearize) ( false branch )
<label> dup #branch linear,
] keep label, ( branch target of BRANCH-T )
swap (linearize) ( true branch )
label, ( branch target of false branch end ) ;
\ #ifte [ linearize-ifte ] "linearizer" set-word-property

125
library/compiler/xt.factor Normal file
View File

@ -0,0 +1,125 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: combinators
USE: dataflow
USE: errors
USE: generator
USE: hashtables
USE: kernel
USE: linearizer
USE: lists
USE: logic
USE: math
USE: namespaces
USE: parser
USE: prettyprint
USE: stack
USE: stdio
USE: strings
USE: unparser
USE: vectors
USE: words
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
! sets the xt of each word in the hashtable to the value in the
! hastable.
!
! This has the advantage that we can compile a word before the
! words it depends on and perform a fixup later; among other
! things this enables mutually recursive words.
SYMBOL: compiled-xts
: save-xt ( word -- )
cell compile-aligned
compiled-offset swap compiled-xts acons@ ;
: commit-xt ( xt word -- )
dup t "compiled" set-word-property set-word-xt ;
: commit-xts ( -- )
compiled-xts get [ unswons commit-xt ] each
compiled-xts off ;
: compiled-xt ( word -- xt )
dup compiled-xts get assoc [ nip ] [ word-xt ] ifte* ;
! "deferred-xts" is a list of [ where word relative ] pairs; the
! xt of word when its done compiling will be written to the
! offset, relative to the offset.
SYMBOL: deferred-xts
! Words being compiled are consed onto this list. When a word
! is encountered that has not been previously compiled, it is
! consed onto this list. Compilation stops when the list is
! empty.
SYMBOL: compile-words
: defer-xt ( word where relative -- )
#! After word is compiled, put its XT at where, relative.
3list deferred-xts cons@ ;
: compiling? ( word -- ? )
#! A word that is compiling or already compiled will not be
#! added to the list of words to be compiled.
dup compiled? [
drop t
] [
dup compile-words get contains? [
drop t
] [
compiled-xts get assoc
] ifte
] ifte ;
: fixup-deferred-xt ( word where relative -- )
rot dup compiling? [
compiled-xt swap - swap set-compiled-cell
] [
"Not compiled: " swap word-name cat2 throw
] ifte ;
: fixup-deferred-xts ( -- )
deferred-xts get [
uncons uncons car fixup-deferred-xt
] each
deferred-xts off ;
: with-compiler ( quot -- )
[
call
fixup-deferred-xts
commit-xts
] with-scope ;
: postpone-word ( word -- )
dup compiling? [ drop ] [ compile-words unique@ ] ifte ;

6
library/inference/branches.factor
View File

@ -133,7 +133,7 @@ USE: hashtables
3 ensure-d 3 ensure-d
dataflow-drop, pop-d dataflow-drop, pop-d
dataflow-drop, pop-d 2list dataflow-drop, pop-d 2list
>r 1 meta-d get vector-tail* IFTE r> >r 1 meta-d get vector-tail* #ifte r>
pop-d drop ( condition ) pop-d drop ( condition )
infer-branches ; infer-branches ;
@ -147,14 +147,14 @@ USE: hashtables
#! Infer effects for all branches, unify. #! Infer effects for all branches, unify.
2 ensure-d 2 ensure-d
dataflow-drop, pop-d vtable>list dataflow-drop, pop-d vtable>list
>r 1 meta-d get vector-tail* GENERIC r> >r 1 meta-d get vector-tail* #generic r>
infer-branches ; infer-branches ;
: infer-2generic ( -- ) : infer-2generic ( -- )
#! Infer effects for all branches, unify. #! Infer effects for all branches, unify.
3 ensure-d 3 ensure-d
dataflow-drop, pop-d vtable>list dataflow-drop, pop-d vtable>list
>r 2 meta-d get vector-tail* 2GENERIC r> >r 2 meta-d get vector-tail* #2generic r>
infer-branches ; infer-branches ;
\ ifte [ infer-ifte ] "infer" set-word-property \ ifte [ infer-ifte ] "infer" set-word-property

17
library/inference/dataflow.factor
View File

@ -39,13 +39,12 @@ USE: vectors
! We build a dataflow graph for the compiler. ! We build a dataflow graph for the compiler.
SYMBOL: dataflow-graph SYMBOL: dataflow-graph
SYMBOL: CALL ( non-tail call ) SYMBOL: #call ( non-tail call )
SYMBOL: JUMP ( tail-call ) SYMBOL: #push ( literal )
SYMBOL: PUSH ( literal )
SYMBOL: IFTE SYMBOL: #ifte
SYMBOL: GENERIC SYMBOL: #generic
SYMBOL: 2GENERIC SYMBOL: #2generic
SYMBOL: node-consume-d SYMBOL: node-consume-d
SYMBOL: node-produce-d SYMBOL: node-produce-d
@ -53,8 +52,8 @@ SYMBOL: node-consume-r
SYMBOL: node-produce-r SYMBOL: node-produce-r
SYMBOL: node-op SYMBOL: node-op
! PUSH nodes have this field set to the value being pushed. ! #push nodes have this field set to the value being pushed.
! CALL nodes have this as the word being called ! #call nodes have this as the word being called
SYMBOL: node-param SYMBOL: node-param
: <dataflow-node> ( param op -- node ) : <dataflow-node> ( param op -- node )
@ -93,4 +92,4 @@ SYMBOL: node-param
: dataflow-drop, ( -- ) : dataflow-drop, ( -- )
#! Remove the top stack element and add a dataflow node #! Remove the top stack element and add a dataflow node
#! noting this. #! noting this.
\ drop CALL dataflow, [ 1 0 node-inputs ] bind ; \ drop #call dataflow, [ 1 0 node-inputs ] bind ;

12
library/inference/inference.factor
View File

@ -110,7 +110,7 @@ DEFER: apply-word
#! Literals are annotated with the current recursive #! Literals are annotated with the current recursive
#! state. #! state.
dup recursive-state get cons push-d dup recursive-state get cons push-d
PUSH dataflow, [ 1 0 node-outputs ] bind ; #push dataflow, [ 1 0 node-outputs ] bind ;
: apply-object ( obj -- ) : apply-object ( obj -- )
#! Apply the object's stack effect to the inferencer state. #! Apply the object's stack effect to the inferencer state.
@ -149,10 +149,12 @@ DEFER: apply-word
#! Stack effect of a quotation. #! Stack effect of a quotation.
[ f init-inference (infer) effect ] with-scope ; [ f init-inference (infer) effect ] with-scope ;
: dataflow ( quot -- dataflow )
#! Data flow of a quotation.
[ f init-inference (infer) get-dataflow ] with-scope ;
: try-infer ( quot -- effect/f ) : try-infer ( quot -- effect/f )
#! Push f if inference fails. #! Push f if inference fails.
[ infer ] [ [ drop f ] when ] catch ; [ infer ] [ [ drop f ] when ] catch ;
IN: dataflow
: dataflow ( quot -- dataflow )
#! Data flow of a quotation.
[ f init-inference (infer) get-dataflow ] with-scope ;

4
library/inference/stack.factor
View File

@ -34,13 +34,13 @@ USE: lists
USE: namespaces USE: namespaces
\ >r [ \ >r [
\ >r CALL dataflow, [ 1 0 node-inputs ] extend \ >r #call dataflow, [ 1 0 node-inputs ] extend
pop-d push-r pop-d push-r
[ 0 1 node-outputs ] bind [ 0 1 node-outputs ] bind
] "infer" set-word-property ] "infer" set-word-property
\ r> [ \ r> [
\ r> CALL dataflow, [ 0 1 node-inputs ] extend \ r> #call dataflow, [ 0 1 node-inputs ] extend
pop-r push-d pop-r push-d
[ 1 0 node-outputs ] bind [ 1 0 node-outputs ] bind
] "infer" set-word-property ] "infer" set-word-property

4
library/inference/words.factor
View File

@ -47,7 +47,7 @@ USE: prettyprint
#! parameters, add node. The quotation is called with the #! parameters, add node. The quotation is called with the
#! stack effect. #! stack effect.
over car ensure-d over car ensure-d
rot CALL dataflow, rot #call dataflow,
[ pick swap dataflow-inputs ] keep [ pick swap dataflow-inputs ] keep
pick 2slip swap dataflow-outputs ; inline pick 2slip swap dataflow-outputs ; inline
@ -149,7 +149,7 @@ USE: prettyprint
] ifte ; ] ifte ;
: infer-call ( [ rstate | quot ] -- ) : infer-call ( [ rstate | quot ] -- )
\ drop CALL dataflow, drop \ drop #call dataflow, drop
[ [
dataflow-graph off dataflow-graph off
pop-d uncons recursive-state set (infer) pop-d uncons recursive-state set (infer)

6
library/test/dataflow.factor
View File

@ -33,7 +33,7 @@ USE: prettyprint
] unit-test ] unit-test
[ t ] [ [ t ] [
IFTE [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean #ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
] unit-test ] unit-test
: dataflow-consume-d-len ( object -- n ) : dataflow-consume-d-len ( object -- n )
@ -47,7 +47,7 @@ USE: prettyprint
[ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test [ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test
: dataflow-ifte-node-consume-d ( list -- node ) : dataflow-ifte-node-consume-d ( list -- node )
IFTE swap dataflow-contains-op? car [ node-consume-d get ] bind ; #ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ;
[ t ] [ [ t ] [
[ 2 [ swap ] [ nip "hi" ] ifte ] dataflow [ 2 [ swap ] [ nip "hi" ] ifte ] dataflow
@ -56,7 +56,7 @@ USE: prettyprint
[ t ] [ [ t ] [
[ { drop no-method drop no-method } generic ] dataflow [ { drop no-method drop no-method } generic ] dataflow
GENERIC swap dataflow-contains-op? car [ #generic swap dataflow-contains-op? car [
node-param get [ node-param get [
[ [ node-param get \ no-method = ] bind ] some? [ [ node-param get \ no-method = ] bind ] some?
] some? ] some?