diff --git a/.gitignore b/.gitignore index b80837f4e2..897825c826 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,5 @@ factor .gdb_history *.*.marks .*.swp +reverse-complement-in.txt +reverse-complement-out.txt diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index fbd49cedbb..7d01fb2b00 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -167,7 +167,7 @@ DEFER: c-ushort-array> swap dup length memcpy ; : string>char-memory ( string base -- ) - >r >byte-array r> byte-array>memory ; + >r B{ } like r> byte-array>memory ; DEFER: >c-ushort-array diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 54348e47f9..282a849c34 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -398,7 +398,7 @@ TUPLE: callback-context ; callback-unwind %unwind ; : generate-callback ( node -- ) - dup alien-callback-xt dup rot [ + dup alien-callback-xt dup [ init-templates %save-word-xt %prologue-later @@ -407,7 +407,7 @@ TUPLE: callback-context ; dup wrap-callback-quot %alien-callback %callback-return ] with-stack-frame - ] generate-1 ; + ] with-generator ; M: alien-callback generate-node end-basic-block generate-callback iterate-next ; diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 9dd56c6524..cd99796e7e 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -111,7 +111,8 @@ SYMBOL: bootstrap-time "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c restarts. + :c + print-error restarts. "listener" vocab-main execute 1 exit ] recover diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 2674734483..f44e6c1387 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -30,7 +30,7 @@ IN: compiler : compile-succeeded ( word -- effect dependencies ) [ - dup word-dataflow >r swap dup r> optimize generate + [ word-dataflow optimize ] keep dup generate ] computing-dependencies ; : compile-failed ( word error -- ) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 12b1cd51ad..38c4ee233e 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math ; +USING: combinators kernel math sequences ; IN: dlists TUPLE: dlist front back length ; @@ -72,6 +72,9 @@ PRIVATE> : push-front ( obj dlist -- ) push-front* drop ; +: push-all-front ( seq dlist -- ) + [ push-front ] curry each ; + : push-back* ( obj dlist -- dlist-node ) [ dlist-back f ] keep [ dlist-back set-next-when ] 2keep @@ -80,11 +83,10 @@ PRIVATE> inc-length ; : push-back ( obj dlist -- ) - [ dlist-back f ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] keep - [ set-front-to-back ] keep - inc-length ; + push-back* drop ; + +: push-all-back ( seq dlist -- ) + [ push-back ] curry each ; : peek-front ( dlist -- obj ) dlist-front dlist-node-obj ; @@ -156,3 +158,6 @@ PRIVATE> over dlist-empty? [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; inline + +: 1dlist ( obj -- dlist ) [ push-front ] keep ; + diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor index f0901fd46f..ef0645a0af 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/core/float-vectors/float-vectors-docs.factor @@ -12,7 +12,7 @@ $nl { $subsection >float-vector } { $subsection } "If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" -{ $code "BV{ } clone" } ; +{ $code "FV{ } clone" } ; ABOUT: "float-vectors" diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 17c0c64bf1..25e2f8222b 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -140,17 +140,19 @@ SYMBOL: literal-table V{ } clone relocation-table set V{ } clone label-table set ; -: generate-labels ( -- labels ) - label-table get [ +: resolve-labels ( labels -- labels' ) + [ first3 label-offset [ "Unresolved label" throw ] unless* 3array ] map concat ; -: fixup ( code -- relocation-table label-table code ) +: fixup ( code -- literals relocation labels code ) [ init-fixup dup stack-frame-size swap [ fixup* ] each drop + + literal-table get >array relocation-table get >array - generate-labels + label-table get resolve-labels ] { } make ; diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index 029749180e..4473df7277 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -22,34 +22,35 @@ HELP: compiled { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ; HELP: compiling-word -{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ; +{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ; HELP: compiling-label -{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ; +{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ; HELP: compiled-stack-traces? { $values { "?" "a boolean" } } { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ; HELP: literal-table -{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ; +{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ; -HELP: init-generator +HELP: begin-compiling +{ $values { "word" word } { "label" word } } { $description "Prepares to generate machine code for a word." } ; -HELP: generate-1 -{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } } +HELP: with-generator +{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } } { $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ; HELP: generate-node { $values { "node" "a dataflow node" } { "next" "a dataflow node" } } { $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." } -{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ; +{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ; HELP: generate-nodes { $values { "node" "a dataflow node" } } { $description "Recursively generate machine code for a dataflow graph." } -{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ; +{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ; HELP: generate { $values { "word" word } { "label" word } { "node" "a dataflow node" } } diff --git a/core/generator/generator.factor b/core/generator/generator.factor index d8164fdce7..8b6742e700 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -11,12 +11,6 @@ IN: generator SYMBOL: compile-queue SYMBOL: compiled -: begin-compiling ( word -- ) - f swap compiled get set-at ; - -: finish-compiling ( word literals relocation labels code -- ) - 4array swap compiled get set-at ; - : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } @@ -32,24 +26,31 @@ SYMBOL: compiling-word SYMBOL: compiling-label +SYMBOL: compiling-loop? + ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start : compiled-stack-traces? ( -- ? ) 36 getenv ; -: init-generator ( -- ) +: begin-compiling ( word label -- ) + compiling-loop? off + compiling-label set + compiling-word set compiled-stack-traces? - compiling-word get f ? - 1vector literal-table set ; + compiling-word get f ? + 1vector literal-table set + f compiling-word get compiled get set-at ; -: generate-1 ( word label node quot -- ) - pick begin-compiling [ - roll compiling-word set - pick compiling-label set - init-generator - call - literal-table get >array - ] { } make fixup finish-compiling ; +: finish-compiling ( literals relocation labels code -- ) + 4array compiling-label get compiled get set-at ; + +: with-generator ( node word label quot -- ) + [ + >r begin-compiling r> + { } make fixup + finish-compiling + ] with-scope ; inline GENERIC: generate-node ( node -- next ) @@ -62,12 +63,12 @@ GENERIC: generate-node ( node -- next ) %prologue-later current-label-start define-label current-label-start resolve-label ; - -: generate ( word label node -- ) + +: generate ( node word label -- ) [ init-generate-nodes [ generate-nodes ] with-node-iterator - ] generate-1 ; + ] with-generator ; : word-dataflow ( word -- effect dataflow ) [ @@ -82,25 +83,6 @@ GENERIC: generate-node ( node -- next ) : if-intrinsics ( #call -- quot ) node-param "if-intrinsics" word-prop ; -DEFER: #terminal? - -PREDICATE: #merge #terminal-merge node-successor #terminal? ; - -PREDICATE: #values #terminal-values node-successor #terminal? ; - -PREDICATE: #call #terminal-call - dup node-successor #if? - over node-successor node-successor #terminal? and - swap if-intrinsics and ; - -UNION: #terminal - POSTPONE: f #return #terminal-values #terminal-merge ; - -: tail-call? ( -- ? ) - node-stack get [ - dup #terminal-call? swap node-successor #terminal? or - ] all? ; - ! node M: node generate-node drop iterate-next ; @@ -112,20 +94,38 @@ M: node generate-node drop iterate-next ; : generate-call ( label -- next ) dup maybe-compile end-basic-block - tail-call? [ - %jump f + dup compiling-label get eq? compiling-loop? get and [ + drop current-label-start get %jump-label f ] [ - 0 frame-required - %call - iterate-next + tail-call? [ + %jump f + ] [ + 0 frame-required + %call + iterate-next + ] if ] if ; ! #label M: #label generate-node dup node-param generate-call >r - dup #label-word over node-param rot node-child generate + dup node-child over #label-word rot node-param generate r> ; +! #loop +M: #loop generate-node + end-basic-block + [ + dup node-param compiling-label set + current-label-start define-label + current-label-start resolve-label + compiling-loop? on + node-child generate-nodes + end-basic-block + ] with-scope + init-templates + iterate-next ; + ! #if : end-false-branch ( label -- ) tail-call? [ %return drop ] [ %jump-label ] if ; @@ -150,12 +150,12 @@ M: #if generate-node ! #dispatch : dispatch-branch ( node word -- label ) gensym [ - rot [ + [ copy-templates %save-dispatch-xt %prologue-later [ generate-nodes ] with-node-iterator - ] generate-1 + ] with-generator ] keep ; : tail-dispatch? ( node -- ? ) @@ -182,10 +182,10 @@ M: #dispatch generate-node generate-dispatch iterate-next ] [ compiling-word get gensym [ - rot [ + [ init-generate-nodes generate-dispatch - ] generate-1 + ] with-generator ] keep generate-call ] if ; @@ -224,10 +224,11 @@ M: #dispatch generate-node : define-if-intrinsic ( word quot inputs -- ) 2array 1array define-if-intrinsics ; -: do-if-intrinsic ( #call pair -- next ) -