classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
-io.encodings.string prettyprint libc compiler.units math.order
-compiler.tree.builder compiler.tree.optimizer ;
+io.encodings.string prettyprint libc splitting math.parser
+compiler.units math.order compiler.tree.builder
+compiler.tree.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
"." write flush
{
- . lines
+ memq? split harvest sift cut cut-slice start index clone
+ set-at reverse push-all class number>string string>number
} compile-uncompiled
"." write flush
{
- malloc calloc free memcpy
+ lines prefix suffix unclip new-assoc update
+ word-prop set-word-prop 1array 2array 3array ?nth
+} compile-uncompiled
+
+"." write flush
+
+{
+ . malloc calloc free memcpy
} compile-uncompiled
{ build-tree } compile-uncompiled
arrays assocs combinators compiler kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects ;
+memoize debugger io.encodings.ascii effects compiler.generator ;
IN: cocoa.messages
: make-sender ( method function -- quot )
{ $subsection column }
{ $subsection <column> }
"A utility word:"
-{ $subsection flipped } ;
+{ $subsection <flipped> } ;
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
] tri ;
: (compile) ( word -- )
- USE: prettyprint dup .
'[
H{ } clone dependencies set
USING: help.syntax help.markup math kernel
-words strings alien ;
+words strings alien compiler.generator ;
IN: compiler.generator.fixup
HELP: frame-required
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
} ;
+
+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 begin-compiling } " ensures that the first entry is the word being compiled." } ;
-USING: help.markup help.syntax words debugger generator.fixup
-generator.registers quotations kernel vectors arrays effects
-sequences ;
+USING: help.markup help.syntax words debugger
+compiler.generator.fixup compiler.generator.registers quotations
+kernel vectors arrays effects sequences ;
IN: compiler.generator
ARTICLE: "generator" "Compiled code generator"
{ $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 begin-compiling } " ensures that the first entry is the word being compiled." } ;
-
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
%jump-label ;
: generate-call ( label -- next )
- ! dup maybe-compile
+ dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
shuffle-effect phantom-shuffle iterate-next ;
M: #>r generate-node
- in-d>> length
- phantom->r
+ [ in-d>> length ] [ out-r>> empty? ] bi
+ [ phantom-drop ] [ phantom->r ] if
iterate-next ;
M: #r> generate-node
- out-d>> length
- phantom-r>
+ [ in-r>> length ] [ out-d>> empty? ] bi
+ [ phantom-rdrop ] [ phantom-r> ] if
iterate-next ;
! #return
: phantom-r> ( n -- )
phantom-retainstack get phantom-input
phantom-datastack get phantom-append ;
+
+: phantom-drop ( n -- )
+ phantom-datastack get phantom-input drop ;
+
+: phantom-rdrop ( n -- )
+ phantom-retainstack get phantom-input drop ;
M: #copy check-node* inputs/outputs 2array check-lengths ;
-M: #>r check-node* inputs/outputs 2array check-lengths ;
+: check->r/r> ( node -- )
+ inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
-M: #r> check-node* inputs/outputs 2array check-lengths ;
+M: #>r check-node* check->r/r> ;
+
+M: #r> check-node* check->r/r> ;
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
bi ;
M: #enter-recursive check-node*
+ [ [ label>> enter-out>> ] [ out-d>> ] bi assert= ]
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ recursive-phi-in check-lengths ]
- bi ;
+ tri ;
M: #push check-node*
out-d>> length 1 = [ "Bad #push" throw ] unless ;
GENERIC: check-stack-flow* ( node -- )
: (check-stack-flow) ( nodes -- )
- [ check-stack-flow* ] each ;
+ [ check-stack-flow* terminated? get not ] all? drop ;
: init-stack-flow ( -- )
V{ } clone datastack set
: check-phi-in ( #phi -- )
phi-in-d>> branch-out get [
- over [ +bottom+ eq? ] all? [
- 2drop
- ] [
+ dup [
over length tail* sequence= [
"Branch outputs don't match phi inputs"
throw
] unless
+ ] [
+ 2drop
] if
] 2each ;
: set-phi-datastack ( #phi -- )
phi-in-d>> first length
- branch-out get [ ] find nip
- dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ;
+ branch-out get [ ] find nip swap head* >vector datastack set ;
M: #phi check-stack-flow*
- [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ;
+ branch-out get [ ] contains? [
+ [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
+ ] [ drop terminated? on ] if ;
M: #recursive check-stack-flow*
- [
- init-stack-flow
- child>> (check-stack-flow)
- datastack get
- ] with-scope
- datastack set ;
+ [ check-in-d ] [ child>> (check-stack-flow) ] bi ;
M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
[ ] [
[ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
] unit-test
+
+[ ] [
+ [
+ [ "X" throw ]
+ [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
+ if
+ ] cleaned-up-tree drop
+] unit-test
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io
-prettyprint ;
+prettyprint words sequences.deep sequences.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: boo ( a b -- c ) 2drop f ;
[ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
+
+: squish ( quot -- quot' )
+ [
+ {
+ { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
+ { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
+ [ ]
+ } cond
+ ] deep-map ;
+
+: call-recursive-dce-1 ( a -- b )
+ [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
+
+[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+ [ call-recursive-dce-1 ] optimize-quot squish
+] unit-test
+
+: produce-a-value ( -- a ) f ;
+
+: call-recursive-dce-2 ( a -- b )
+ drop
+ produce-a-value dup . call-recursive-dce-2 ; inline recursive
+
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
+ [ f call-recursive-dce-2 drop ] optimize-quot squish
+] unit-test
+
+[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+ [ f call-recursive-dce-2 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-3 ( a -- )
+ call-recursive-dce-3 ; inline recursive
+
+[ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
+ [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+ [ call-recursive-dce-3 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-4 ( a -- b )
+ call-recursive-dce-4 ; inline recursive
+
+[ [ "WRAP" [ "REC" ] label ] ] [
+ [ call-recursive-dce-4 ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+ [ call-recursive-dce-4 drop ] optimize-quot squish
+] unit-test
+
+[ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
+
+[ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
+ dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
+
+[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.tree compiler.tree.dead-code.branches
+USING: accessors arrays assocs sequences kernel locals fry
+combinators stack-checker.backend
+compiler.tree
+compiler.tree.dead-code.branches
compiler.tree.dead-code.liveness
compiler.tree.dead-code.simple ;
IN: compiler.tree.dead-code.recursive
M: #enter-recursive compute-live-values*
+ #! If the output of an #enter-recursive is live, then the
+ #! corresponding inputs to the #call-recursive are live also.
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
: return-recursive-phi-in ( #return-recursive -- phi-in )
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
M: #call-recursive compute-live-values*
- #! If the output of a copy is live, then the corresponding
- #! inputs to #return nodes are live also.
+ #! If the output of a #call-recursive is live, then the
+ #! corresponding inputs to #return nodes are live also.
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
-M: #recursive remove-dead-code*
- [ filter-live ] change-in-d
- [ (remove-dead-code) ] change-child ;
+:: drop-dead-inputs ( inputs outputs -- #shuffle )
+ [let* | new-inputs [ inputs make-values ]
+ live-inputs [ outputs inputs filter-corresponding ]
+ new-live-inputs [ outputs new-inputs filter-corresponding ]
+ mapping [ new-live-inputs live-inputs zip ] |
+ inputs filter-live
+ new-live-inputs
+ mapping
+ #shuffle
+ ] ;
-M: #call-recursive remove-dead-code*
- [ filter-live ] change-in-d
- [ filter-live ] change-out-d ;
+M: #recursive remove-dead-code* ( node -- nodes )
+ dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
+ {
+ [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
+ [ drop [ (remove-dead-code) ] change-child drop ]
+ [ drop label>> [ filter-live ] change-enter-out drop ]
+ [ swap 2array ]
+ } 2cleave ;
M: #enter-recursive remove-dead-code*
- [ filter-live ] change-in-d
[ filter-live ] change-out-d ;
-M: #return-recursive remove-dead-code*
- [ filter-live ] change-in-d
- [ filter-live ] change-out-d ;
+: drop-call-recursive-inputs ( node -- #shuffle )
+ dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
+ [ out-d>> >>in-d drop ]
+ [ nip ]
+ 2bi ;
+
+:: drop-call-recursive-outputs ( node -- #shuffle )
+ [let* | node-out [ node out-d>> ]
+ return-in [ node label>> return>> in-d>> ]
+ node-out-live [ return-in node-out filter-corresponding ]
+ new-node-out-live [ node-out-live make-values ]
+ node-out-dropped [ node-out filter-live ]
+ new-node-out-dropped [ node-out-dropped new-node-out-live filter-corresponding ]
+ mapping [ node-out-dropped new-node-out-dropped zip ] |
+ node new-node-out-live >>out-d drop
+ new-node-out-live node-out-dropped mapping #shuffle
+ ] ;
+
+M: #call-recursive remove-dead-code*
+ [ drop-call-recursive-inputs ]
+ [ ]
+ [ drop-call-recursive-outputs ]
+ tri 3array ;
+
+M: #return-recursive remove-dead-code* ( node -- nodes )
+ dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
+ [ drop [ filter-live ] change-out-d drop ]
+ [ out-d>> >>in-d drop ]
+ [ swap 2array ]
+ 2tri ;
: filter-mapping ( assoc -- assoc' )
live-values get '[ drop , key? ] assoc-filter ;
-: filter-corresponding ( new old -- new' )
+: filter-corresponding ( new old -- old' )
+ #! Remove elements from 'old' if the element with the same
+ #! index in 'new' is dead.
zip filter-mapping values ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
+: drop-dead-values ( in out -- #shuffle )
+ [ make-values dup ] keep zip #shuffle ;
+
:: drop-dead-outputs ( node -- nodes )
[let* | old-outputs [ node out-d>> ]
new-outputs [ old-outputs make-values ]
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel math ;
+compiler.tree compiler.tree.checker
+sequences accessors tools.test kernel math ;
\ count-introductions must-infer
\ normalize must-infer
[ normalize recursive-inputs ] bi
] unit-test
-[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
DEFER: bbb
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
-[ ] [ [ bbb ] build-tree normalize drop ] unit-test
+[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
: ccc ( -- ) ccc drop 1 ; inline recursive
-[ ] [ [ ccc ] build-tree normalize drop ] unit-test
+[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
DEFER: eee
: ddd ( -- ) eee ; inline recursive
: eee ( -- ) swap ddd ; inline recursive
-[ ] [ [ eee ] build-tree normalize drop ] unit-test
+[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
+
+: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
+
+[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test
compute-def-use
remove-dead-code
! strength-reduce
- compute-def-use USE: kernel
- dup check-nodes ;
+ ;
[ ] [ [ instance? ] final-classes drop ] unit-test
[ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
+
+: fold-throw-test ( a -- b ) "A" throw ; foldable
+
+[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
: fold-call ( #call word -- infos )
- [ in-d>> [ value-info literal>> ] map ]
- [ [ execute ] curry ]
- bi* with-datastack
- [ <literal-info> ] map ;
+ [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
+ '[ , , with-datastack [ <literal-info> ] map nip ]
+ [ drop [ object-info ] replicate ]
+ recover ;
: predicate-output-infos ( info class -- info )
[ class>> ] dip {
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
-accessors combinators stack-checker.state stack-checker.visitor ;
+accessors combinators stack-checker.state stack-checker.visitor
+stack-checker.inlining ;
IN: compiler.tree
! High-level tree SSA form.
[ flatten-values ] change-out-d ;
M: #recursive unbox-tuples*
- [ flatten-values ] change-in-d ;
+ [ label>> [ flatten-values ] change-enter-out drop ]
+ [ [ flatten-values ] change-in-d ]
+ bi ;
M: #enter-recursive unbox-tuples*
[ flatten-values ] change-in-d
PREDICATE: small-tagged < integer v>operand small-enough? ;
: if-small-struct ( n size true false -- ? )
- >r >r over not over struct-small-enough? and
- [ nip r> call r> drop ] [ r> drop r> call ] if ;
+ [ over not over struct-small-enough? and ] 2dip
+ [ [ nip ] prepose ] dip if ;
inline
: %unbox-struct ( n size -- )
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces sequences words generator
+math memory namespaces sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts combinators compiler.constants math.order ;
IN: cpu.x86.architecture
USING: help.markup help.syntax io kernel math namespaces parser
-prettyprint sequences vocabs.loader namespaces inference ;
+prettyprint sequences vocabs.loader namespaces stack-checker ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
"classes.predicate"
"compiler.units"
"continuations.private"
- "generator"
"growable"
"hashtables"
"hashtables.private"
: update-slot ( old-values n class initial -- value )
pick [
- >r >r swap nth dup r> instance?
- [ r> drop ] [ drop r> ] if
+ >r >r swap nth dup r> instance? r> swap
+ [ drop ] [ nip ] if
] [ >r 3drop r> ] if ;
: apply-slot-permutation ( old-values triples -- new-values )
: c> ( -- continuation ) catchstack* pop ;
-: dummy ( -- obj )
- #! Optimizing compiler assumes stack won't be messed with
- #! in-transit. To ensure that a value is actually reified
- #! on the stack, we put it in a non-inline word together
- #! with a declaration.
- f { object } declare ;
+! We have to defeat some optimizations to make continuations work
+: dummy-1 ( -- obj ) f ;
+: dummy-2 ( obj -- obj ) dup drop ;
: init-catchstack ( -- ) V{ } clone 1 setenv ;
#! ( value f r:capture r:restore )
#! Execution begins right after the call to 'continuation'.
#! The 'restore' branch is taken.
- >r >r dummy continuation r> r> ?if ; inline
+ >r >r dummy-1 continuation r> r> [ dummy-2 ] prepose ?if ; inline
: callcc0 ( quot -- ) [ drop ] ifcc ; inline
lexer new-lexer ;
: skip ( i seq ? -- n )
- over >r
+ >r tuck r>
[ swap CHAR: \s eq? xor ] curry find-from drop
- [ r> drop ] [ r> length ] if* ;
+ [ ] [ length ] ?if ;
: change-lexer-column ( lexer quot -- )
swap
projects / factor.git / commitdiff