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

Listener auto-compiles; more smart recompile work in progress

db4
Slava Pestov 2007-12-17 16:29:54 -05:00
parent 51992905b2
commit 308cf5aef7
7 changed files with 115 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
core/compiler/batch/batch.factor Normal file → Executable file
View File

@ -5,50 +5,46 @@ optimizer arrays definitions sequences assocs
continuations generator compiler ;
IN: compiler.batch
! SYMBOL: compile-queue
! SYMBOL: compile-results
!
! TUPLE: compiled literals words rel labels code ;
!
! C: <compiled> compiled
!
! : queue-compile ( word -- )
! compile-queue get push-front ;
!
! : word-dataflow ( word -- effect dataflow )
! [
! dup "no-effect" word-prop [ no-effect ] when
! dup specialized-def over dup 2array 1array infer-quot
! finish-word
! ] with-infer ;
!
! : compiled-usage usage [ word? ] subset ;
!
! : ripple-up ( effect word -- )
! tuck "compiled-effect" word-prop =
! [ drop ] [ compiled-usage [ queue-compile ] each ] if ;
!
! : save-effect ( effect word -- )
! swap "compiled-effect" set-word-prop ;
!
! : add-compiled ( word -- )
! >r f f f f f <compiled> r> compile-results get set-at ;
!
! : compile-1 ( word -- )
! dup compile-results get at [ drop ] [
! [ [ word-dataflow drop ] [ 2drop f ] recover ] keep
! 2dup ripple-up
! tuck save-effect
! add-compiled
! ] if ;
!
! : compile-batch ( words -- )
! [
! <dlist> compile-queue set
! [ queue-compile ] each
! H{ } clone compile-results set
! compile-queue get [ compile-1 ] dlist-slurp
! compile-results get
! ] with-scope ;
: with-compilation-unit ( quot -- )
H{ } clone
[ compiled-xts swap with-variable ] keep
[ swap add* ] { } assoc>map modify-code-heap ;
: compile-batch ( words -- )
[ [ (compile) ] curry [ print-error ] recover ] each ;
SYMBOL: compile-queue
: queue-compile ( word -- )
compile-queue get push-front ;
: compiled-usage ( word -- seq )
#! XXX
usage [ word? ] subset ;
: ripple-up ( effect word -- )
tuck "compiled-effect" word-prop =
[ drop ] [ compiled-usage [ queue-compile ] each ] if ;
: save-effect ( effect word -- )
swap "compiled-effect" set-word-prop ;
: add-compiled ( word -- )
>r f f f f f <compiled> r> compile-results get set-at ;
: compile-1 ( word -- )
dup compile-results get at [ drop ] [
[ [ word-dataflow drop ] [ 2drop f ] recover ] keep
2dup ripple-up
tuck save-effect
add-compiled
] if ;
: compile-batch ( words -- )
[
<dlist> compile-queue set
[ queue-compile ] each
H{ } clone compile-results set
compile-queue get [ compile-1 ] dlist-slurp
compile-results get
] with-scope ;

46
core/compiler/compiler.factor
View File

@ -2,23 +2,49 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
generator debugger math.parser prettyprint words continuations
vocabs assocs alien.compiler ;
vocabs assocs alien.compiler dlists optimizer ;
IN: compiler
SYMBOL: compiler-hook
: compile-begins ( word -- )
compiler-hook get [ call ] when*
"quiet" get [ drop ] [ "Compiling " write . flush ] if ;
: (compile) ( word -- )
dup compiling? not over compound? and [
[
dup compile-begins
dup dup word-dataflow nip optimize generate
] curry [ print-error ] recover
] [ drop ] if ;
: finish-compilation-unit ( assoc -- )
[ swap add* ] { } assoc>map modify-code-heap ;
: with-compilation-unit ( quot -- )
[
<dlist> compile-queue set
H{ } clone compiled-xts set
call
compile-queue get [ (compile) ] dlist-slurp
compiled-xts get finish-compilation-unit
] with-scope ; inline
: compile-batch ( words -- )
H{ } clone [
compiled-xts [
[ [ (compile) ] curry [ print-error ] recover ] each
] with-variable
] keep [ swap add* ] { } assoc>map modify-code-heap ;
[ [ queue-compile ] each ] with-compilation-unit ;
: compile ( word -- ) 1array compile-batch ;
: compile ( word -- )
[ queue-compile ] with-compilation-unit ;
: compile-vocabs ( seq -- ) [ words ] map concat compile-batch ;
: compile-vocabs ( seq -- )
[ words ] map concat compile-batch ;
: compile-quot ( quot -- word ) define-temp dup compile ;
: compile-quot ( quot -- word )
define-temp dup compile ;
: compile-1 ( quot -- ) compile-quot execute ;
: compile-1 ( quot -- )
compile-quot execute ;
: recompile ( -- )
changed-words get [

4
core/generator/generator-docs.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax words debugger generator.fixup
generator.registers quotations kernel vectors arrays ;
generator.registers quotations kernel vectors arrays effects ;
IN: generator
ARTICLE: "generator" "Compiled code generator"
@ -64,7 +64,7 @@ HELP: generate
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
HELP: word-dataflow
{ $values { "word" word } { "dataflow" "a dataflow graph" } }
{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } }
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
HELP: define-intrinsics

46
core/generator/generator.factor
View File

@ -4,13 +4,20 @@ USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ;
quotations sequences system threads words dlists ;
IN: generator
SYMBOL: compile-queue
SYMBOL: compiled-xts
: save-xt ( word xt -- )
swap dup unchanged-word compiled-xts get set-at ;
: 6array 3array >r 3array r> append ;
: begin-compiling ( word -- )
f swap compiled-xts get set-at ;
: finish-compiling ( word literals words rel labels code -- )
6array swap dup unchanged-word compiled-xts get set-at ;
: compiling? ( word -- ? )
{
@ -19,6 +26,9 @@ SYMBOL: compiled-xts
{ [ t ] [ compiled? ] }
} cond ;
: queue-compile ( word -- )
compile-queue get push-front ;
SYMBOL: compiling-word
SYMBOL: compiling-label
@ -36,17 +46,15 @@ t compiled-stack-traces? set-global
compiled-stack-traces? get compiling-word get f ?
literal-table get push ;
: 6array 3array >r 3array r> append ;
: generate-1 ( word label node quot -- )
pick f save-xt [
pick begin-compiling [
roll compiling-word set
pick compiling-label set
init-generator
call
literal-table get >array
word-table get >array
] { } make fixup 6array save-xt ;
] { } make fixup finish-compiling ;
: generate-profiler-prologue ( -- )
compiled-stack-traces? get [
@ -70,30 +78,12 @@ GENERIC: generate-node ( node -- next )
profiler-prologue get
] generate-1 ;
: word-dataflow ( word -- dataflow )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer nip ;
SYMBOL: compiler-hook
[ ] compiler-hook set-global
SYMBOL: compile-errors
: compile-begins ( word -- )
compiler-hook get call
"quiet" get [ drop ] [ "Compiling " write . flush ] if ;
: (compile) ( word -- )
dup compiling? not over compound? and [
dup compile-begins
dup dup word-dataflow optimize generate
] [
drop
] if ;
] with-infer ;
: intrinsics ( #call -- quot )
node-param "intrinsics" word-prop ;
@ -140,7 +130,7 @@ M: node generate-node drop iterate-next ;
} cond ;
: generate-call ( label -- next )
dup (compile)
dup queue-compile
end-basic-block
tail-call? [
%jump f

2
core/listener/listener.factor
View File

@ -48,7 +48,7 @@ M: duplex-stream parse-interactive
listener-hook get call prompt.
[
stdio get parse-interactive
[ do-parse-hook call ] [ bye ] if*
[ call ] [ bye ] if*
] try ;
: until-quit ( -- )

4
core/parser/parser.factor
View File

@ -443,8 +443,8 @@ SYMBOL: parse-hook
\ contents get string-lines parse-fresh
dup finish-parsing
do-parse-hook
] with-scope
] [ ] [ undo-parsing ] cleanup ;
] [ ] [ undo-parsing ] cleanup
] with-scope ;
: parse-file-restarts ( file -- restarts )
"Load " swap " again" 3append t 2array 1array ;

18
vm/code_heap.c
View File

@ -38,6 +38,11 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
static CELL xt_offset;
void incompatible_call_error(void)
{
critical_error("Calling non-optimized word from optimized word",0);
}
/* Compute an address to store at a relocation */
INLINE CELL compute_code_rel(F_REL *rel,
CELL code_start, CELL literals_start, CELL words_start)
@ -56,10 +61,16 @@ INLINE CELL compute_code_rel(F_REL *rel,
return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT:
word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
return (CELL)word->code + sizeof(F_COMPILED) + xt_offset;
if(word->compiledp == F)
return (CELL)incompatible_call_error;
else
return (CELL)word->code + sizeof(F_COMPILED) + xt_offset;
case RT_XT_PROFILING:
word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
return (CELL)word->code + sizeof(F_COMPILED);
if(word->compiledp == F)
return (CELL)incompatible_call_error;
else
return (CELL)word->code + sizeof(F_COMPILED);
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
default:
@ -365,5 +376,6 @@ DEFINE_PRIMITIVE(modify_code_heap)
set_word_xt(word,compiled);
}
iterate_code_heap(finalize_code_block);
if(count != 0)
iterate_code_heap(finalize_code_block);
}