Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
a1483c0497
|
|
@ -1,5 +1,6 @@
|
|||
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USE: math
|
||||
IN: math.constants
|
||||
|
||||
: e ( -- e ) 2.7182818284590452354 ; inline
|
||||
|
|
@ -7,3 +8,5 @@ IN: math.constants
|
|||
: phi ( -- phi ) 1.61803398874989484820 ; inline
|
||||
: pi ( -- pi ) 3.14159265358979323846 ; inline
|
||||
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
|
||||
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
|
||||
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
USING: help.markup help.syntax kernel sequences ;
|
||||
IN: persistent.deques
|
||||
|
||||
ARTICLE: "persistent.deques" "Persistent deques"
|
||||
"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern."
|
||||
$nl
|
||||
"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one."
|
||||
$nl
|
||||
"The class of persistent deques:"
|
||||
{ $subsection deque }
|
||||
"To create a deque:"
|
||||
{ $subsection <deque> }
|
||||
{ $subsection sequence>deque }
|
||||
"To test if a deque is empty:"
|
||||
{ $subsection deque-empty? }
|
||||
"To manipulate deques:"
|
||||
{ $subsection push-left }
|
||||
{ $subsection push-right }
|
||||
{ $subsection pop-left }
|
||||
{ $subsection pop-right }
|
||||
{ $subsection deque>sequence } ;
|
||||
|
||||
HELP: deque
|
||||
{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ;
|
||||
|
||||
HELP: <deque>
|
||||
{ $values { "deque" "an empty deque" } }
|
||||
{ $description "Creates an empty deque." } ;
|
||||
|
||||
HELP: sequence>deque
|
||||
{ $values { "sequence" sequence } { "deque" deque } }
|
||||
{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ;
|
||||
|
||||
HELP: deque>sequence
|
||||
{ $values { "deque" deque } { "sequence" sequence } }
|
||||
{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ;
|
||||
|
||||
HELP: deque-empty?
|
||||
{ $values { "deque" deque } { "?" "t/f" } }
|
||||
{ $description "Returns true if the deque is empty. This takes constant time." } ;
|
||||
|
||||
HELP: push-left
|
||||
{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
|
||||
{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ;
|
||||
|
||||
HELP: push-right
|
||||
{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
|
||||
{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ;
|
||||
|
||||
HELP: pop-left
|
||||
{ $values { "deque" object } { "item" object } { "newdeque" deque } }
|
||||
{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ;
|
||||
|
||||
HELP: pop-right
|
||||
{ $values { "deque" object } { "item" object } { "newdeque" deque } }
|
||||
{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ;
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test persistent.deques kernel math ;
|
||||
IN: persistent.deques.tests
|
||||
|
||||
[ 3 2 1 t ]
|
||||
[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test
|
||||
|
||||
[ 1 2 3 t ]
|
||||
[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test
|
||||
|
||||
[ 1 3 2 t ]
|
||||
[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ]
|
||||
unit-test
|
||||
|
||||
[ { 2 3 4 5 6 1 } ]
|
||||
[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ]
|
||||
unit-test
|
||||
|
||||
[ 1 t ] [ <deque> 1 push-left pop-right deque-empty? ] unit-test
|
||||
[ 1 t ] [ <deque> 1 push-left pop-left deque-empty? ] unit-test
|
||||
[ 1 t ] [ <deque> 1 push-right pop-left deque-empty? ] unit-test
|
||||
[ 1 t ] [ <deque> 1 push-right pop-right deque-empty? ] unit-test
|
||||
|
||||
[ 1 f ]
|
||||
[ <deque> 1 push-left 2 push-left pop-right deque-empty? ] unit-test
|
||||
|
||||
[ 1 f ]
|
||||
[ <deque> 1 push-right 2 push-right pop-left deque-empty? ] unit-test
|
||||
|
||||
[ 2 f ]
|
||||
[ <deque> 1 push-right 2 push-right pop-right deque-empty? ] unit-test
|
||||
|
||||
[ 2 f ]
|
||||
[ <deque> 1 push-left 2 push-left pop-left deque-empty? ] unit-test
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math qualified ;
|
||||
QUALIFIED: sequences
|
||||
IN: persistent.deques
|
||||
|
||||
! Amortized O(1) push/pop on both ends for single-threaded access
|
||||
! In a pathological case, if there are m modified versions from the
|
||||
! same source, it could take O(m) amortized time per update.
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: cons { car read-only } { cdr read-only } ;
|
||||
C: <cons> cons
|
||||
|
||||
: each ( list quot -- )
|
||||
over
|
||||
[ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
|
||||
[ 2drop ] if ; inline
|
||||
|
||||
: reduce ( list start quot -- end )
|
||||
swapd each ; inline
|
||||
|
||||
: reverse ( list -- reversed )
|
||||
f [ swap <cons> ] reduce ;
|
||||
|
||||
: length ( list -- length )
|
||||
0 [ drop 1+ ] reduce ;
|
||||
|
||||
: cut ( list index -- back front-reversed )
|
||||
f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
|
||||
|
||||
: split-reverse ( list -- back-reversed front )
|
||||
dup length 2/ cut [ reverse ] bi@ ;
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: deque { lhs read-only } { rhs read-only } ;
|
||||
: <deque> ( -- deque ) T{ deque } ;
|
||||
|
||||
: deque-empty? ( deque -- ? )
|
||||
[ lhs>> ] [ rhs>> ] bi or not ;
|
||||
|
||||
: push-left ( deque item -- newdeque )
|
||||
swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
|
||||
|
||||
: push-right ( deque item -- newdeque )
|
||||
swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
|
||||
|
||||
<PRIVATE
|
||||
: (pop-left) ( deque -- item newdeque )
|
||||
[ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
|
||||
|
||||
: transfer-left ( deque -- item newdeque )
|
||||
rhs>> [ split-reverse deque boa (pop-left) ]
|
||||
[ "Popping from an empty deque" throw ] if* ;
|
||||
PRIVATE>
|
||||
|
||||
: pop-left ( deque -- item newdeque )
|
||||
dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
|
||||
|
||||
<PRIVATE
|
||||
: (pop-right) ( deque -- item newdeque )
|
||||
[ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
|
||||
|
||||
: transfer-right ( deque -- newdeque item )
|
||||
lhs>> [ split-reverse deque boa (pop-left) ]
|
||||
[ "Popping from an empty deque" throw ] if* ;
|
||||
PRIVATE>
|
||||
|
||||
: pop-right ( deque -- item newdeque )
|
||||
dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
|
||||
|
||||
: sequence>deque ( sequence -- deque )
|
||||
<deque> [ push-right ] sequences:reduce ;
|
||||
|
||||
: deque>sequence ( deque -- sequence )
|
||||
[ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Persistent amortized O(1) deques
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -48,8 +48,8 @@ DEFER: (del-page)
|
|||
: del-page ( name tabbed -- )
|
||||
[ names>> index ] 2keep (del-page) ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed )
|
||||
tabbed new-frame
|
||||
: new-tabbed ( assoc class -- tabbed )
|
||||
new-frame
|
||||
0 <model> >>model
|
||||
<pile> 1 >>fill >>toggler
|
||||
dup toggler>> @left grid-add
|
||||
|
|
@ -59,3 +59,4 @@ DEFER: (del-page)
|
|||
bi
|
||||
dup redo-toggler ;
|
||||
|
||||
: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces sequences strings words assocs
|
||||
combinators accessors arrays ;
|
||||
USING: kernel math math.parser namespaces sequences strings
|
||||
words assocs combinators accessors arrays ;
|
||||
IN: effects
|
||||
|
||||
TUPLE: effect in out terminated? ;
|
||||
|
|
@ -25,10 +25,11 @@ TUPLE: effect in out terminated? ;
|
|||
GENERIC: effect>string ( obj -- str )
|
||||
M: string effect>string ;
|
||||
M: word effect>string name>> ;
|
||||
M: integer effect>string drop "object" ;
|
||||
M: integer effect>string number>string ;
|
||||
M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ;
|
||||
|
||||
: stack-picture ( seq -- string )
|
||||
dup integer? [ "object" <repetition> ] when
|
||||
[ [ effect>string % CHAR: \s , ] each ] "" make ;
|
||||
|
||||
M: effect effect>string ( effect -- string )
|
||||
|
|
|
|||
|
|
@ -629,7 +629,7 @@ HELP: 2bi*
|
|||
"The following two lines are equivalent:"
|
||||
{ $code
|
||||
"[ p ] [ q ] 2bi*"
|
||||
">r >r q r> r> q"
|
||||
">r >r p r> r> q"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot )
|
|||
tri* if
|
||||
] with-scope ; inline
|
||||
|
||||
: cut-amb ( -- )
|
||||
f failure set ;
|
||||
|
|
|
|||
|
|
@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
|
|||
IN: irc.ui.commands
|
||||
|
||||
: say ( string -- )
|
||||
[ client get profile>> nickname>> <own-message> print-irc ]
|
||||
[ listener get write-message ] bi ;
|
||||
irc-tab get
|
||||
[ window>> client>> profile>> nickname>> <own-message> print-irc ]
|
||||
[ listener>> write-message ] 2bi ;
|
||||
|
||||
: join ( string -- )
|
||||
irc-tab get window>> join-channel ;
|
||||
|
||||
: query ( string -- )
|
||||
irc-tab get window>> query-nick ;
|
||||
|
||||
: quote ( string -- )
|
||||
drop ; ! THIS WILL CHANGE
|
||||
|
|
|
|||
|
|
@ -19,9 +19,9 @@ SYMBOL: listener
|
|||
|
||||
SYMBOL: client
|
||||
|
||||
TUPLE: ui-window client tabs ;
|
||||
TUPLE: ui-window < tabbed client ;
|
||||
|
||||
TUPLE: irc-tab < frame listener client userlist ;
|
||||
TUPLE: irc-tab < frame listener client window userlist ;
|
||||
|
||||
: write-color ( str color -- )
|
||||
foreground associate format ;
|
||||
|
|
@ -161,44 +161,54 @@ M: object handle-inbox
|
|||
<scrolling-pane>
|
||||
[ <pane-stream> swap display ] 2keep ;
|
||||
|
||||
TUPLE: irc-editor < editor outstream listener client ;
|
||||
TUPLE: irc-editor < editor outstream tab ;
|
||||
|
||||
: <irc-editor> ( tab pane -- tab editor )
|
||||
over irc-editor new-editor
|
||||
swap listener>> >>listener swap <pane-stream> >>outstream
|
||||
over client>> >>client ;
|
||||
irc-editor new-editor
|
||||
swap <pane-stream> >>outstream ;
|
||||
|
||||
: editor-send ( irc-editor -- )
|
||||
{ [ outstream>> ]
|
||||
[ listener>> ]
|
||||
[ client>> ]
|
||||
[ [ irc-tab? ] find-parent ]
|
||||
[ editor-string ]
|
||||
[ "" swap set-editor-string ] } cleave
|
||||
'[ , listener set , client set , parse-message ] with-output-stream ;
|
||||
'[ , irc-tab set , parse-message ] with-output-stream ;
|
||||
|
||||
irc-editor "general" f {
|
||||
{ T{ key-down f f "RET" } editor-send }
|
||||
{ T{ key-down f f "ENTER" } editor-send }
|
||||
} define-command-map
|
||||
|
||||
: <irc-tab> ( listener client -- irc-tab )
|
||||
irc-tab new-frame
|
||||
swap client>> >>client swap >>listener
|
||||
: new-irc-tab ( listener ui-window class -- irc-tab )
|
||||
new-frame
|
||||
swap >>window
|
||||
swap >>listener
|
||||
<irc-pane> [ <scroller> @center grid-add ] keep
|
||||
<irc-editor> <scroller> @bottom grid-add ;
|
||||
|
||||
: <irc-channel-tab> ( listener client -- irc-tab )
|
||||
<irc-tab>
|
||||
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
|
||||
|
||||
: <irc-server-tab> ( listener client -- irc-tab )
|
||||
<irc-tab> ;
|
||||
|
||||
M: irc-tab graft*
|
||||
[ listener>> ] [ client>> ] bi add-listener ;
|
||||
[ listener>> ] [ window>> client>> ] bi add-listener ;
|
||||
|
||||
M: irc-tab ungraft*
|
||||
[ listener>> ] [ client>> ] bi remove-listener ;
|
||||
[ listener>> ] [ window>> client>> ] bi remove-listener ;
|
||||
|
||||
TUPLE: irc-channel-tab < irc-tab userlist ;
|
||||
|
||||
: <irc-channel-tab> ( listener ui-window -- irc-tab )
|
||||
irc-tab new-irc-tab
|
||||
<pile> [ <scroller> @right grid-add ] keep >>userlist ;
|
||||
|
||||
TUPLE: irc-server-tab < irc-tab ;
|
||||
|
||||
: <irc-server-tab> ( listener -- irc-tab )
|
||||
f irc-server-tab new-irc-tab ;
|
||||
|
||||
M: irc-server-tab ungraft*
|
||||
[ window>> client>> terminate-irc ]
|
||||
[ listener>> ] [ window>> client>> ] tri remove-listener ;
|
||||
|
||||
: <irc-nick-tab> ( listener ui-window -- irc-tab )
|
||||
irc-tab new-irc-tab ;
|
||||
|
||||
M: irc-tab pref-dim*
|
||||
drop { 480 480 } ;
|
||||
|
|
@ -206,19 +216,25 @@ M: irc-tab pref-dim*
|
|||
: join-channel ( name ui-window -- )
|
||||
[ dup <irc-channel-listener> ] dip
|
||||
[ <irc-channel-tab> swap ] keep
|
||||
tabs>> add-page ;
|
||||
add-page ;
|
||||
|
||||
: query-nick ( nick ui-window -- )
|
||||
[ dup <irc-nick-listener> ] dip
|
||||
[ <irc-nick-tab> swap ] keep
|
||||
add-page ;
|
||||
|
||||
: irc-window ( ui-window -- )
|
||||
[ tabs>> ]
|
||||
[ ]
|
||||
[ client>> profile>> server>> ] bi
|
||||
open-window ;
|
||||
|
||||
: ui-connect ( profile -- ui-window )
|
||||
<irc-client> ui-window new over >>client swap
|
||||
[ connect-irc ]
|
||||
[ [ <irc-server-listener> ] dip add-listener ]
|
||||
[ listeners>> +server-listener+ swap at over <irc-tab>
|
||||
"Server" associate <tabbed> >>tabs ] tri ;
|
||||
<irc-client>
|
||||
{ [ [ <irc-server-listener> ] dip add-listener ]
|
||||
[ listeners>> +server-listener+ swap at <irc-server-tab> dup
|
||||
"Server" associate ui-window new-tabbed [ swap (>>window) ] keep ]
|
||||
[ >>client ]
|
||||
[ connect-irc ] } cleave ;
|
||||
|
||||
: server-open ( server port nick password channels -- )
|
||||
[ <irc-profile> ui-connect [ irc-window ] keep ] dip
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: compiler.cfg.builder.tests
|
||||
USING: compiler.cfg.builder tools.test ;
|
||||
|
||||
\ build-cfg must-infer
|
||||
|
|
@ -1,29 +1,33 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel assocs sequences sequences.lib fry accessors
|
||||
compiler.cfg compiler.vops compiler.vops.builder
|
||||
namespaces math inference.dataflow optimizer.allot combinators
|
||||
math.order ;
|
||||
namespaces math combinators math.order
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg
|
||||
compiler.vops
|
||||
compiler.vops.builder ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
! Convert dataflow IR to procedure CFG.
|
||||
! Convert tree SSA IR to CFG SSA IR.
|
||||
|
||||
! We construct the graph and set successors first, then we
|
||||
! set predecessors in a separate pass. This simplifies the
|
||||
! logic.
|
||||
|
||||
SYMBOL: procedures
|
||||
|
||||
SYMBOL: values>vregs
|
||||
|
||||
SYMBOL: loop-nesting
|
||||
|
||||
GENERIC: convert* ( node -- )
|
||||
SYMBOL: values>vregs
|
||||
|
||||
GENERIC: convert ( node -- )
|
||||
|
||||
M: #introduce convert drop ;
|
||||
|
||||
: init-builder ( -- )
|
||||
H{ } clone values>vregs set
|
||||
V{ } clone loop-nesting set ;
|
||||
H{ } clone values>vregs set ;
|
||||
|
||||
: end-basic-block ( -- )
|
||||
basic-block get [ %b emit ] when ;
|
||||
|
|
@ -40,15 +44,12 @@ GENERIC: convert ( node -- )
|
|||
set-basic-block ;
|
||||
|
||||
: convert-nodes ( node -- )
|
||||
dup basic-block get and [
|
||||
[ convert ] [ successor>> convert-nodes ] bi
|
||||
] [ drop ] if ;
|
||||
[ convert ] each ;
|
||||
|
||||
: (build-cfg) ( node word -- )
|
||||
init-builder
|
||||
begin-basic-block
|
||||
basic-block get swap procedures get set-at
|
||||
%prolog emit
|
||||
convert-nodes ;
|
||||
|
||||
: build-cfg ( node word -- procedures )
|
||||
|
|
@ -73,10 +74,9 @@ GENERIC: convert ( node -- )
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
: load-inputs ( node -- )
|
||||
[ in-d>> %data (load-inputs) ]
|
||||
[ in-r>> %retain (load-inputs) ]
|
||||
bi ;
|
||||
: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
|
||||
|
||||
: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
|
||||
|
||||
: (store-outputs) ( seq stack -- )
|
||||
over empty? [ 2drop ] [
|
||||
|
|
@ -86,40 +86,21 @@ GENERIC: convert ( node -- )
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
: store-outputs ( node -- )
|
||||
[ out-d>> %data (store-outputs) ]
|
||||
[ out-r>> %retain (store-outputs) ]
|
||||
bi ;
|
||||
: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
|
||||
|
||||
M: #push convert*
|
||||
out-d>> [
|
||||
[ produce-vreg ] [ value-literal ] bi
|
||||
emit-literal
|
||||
] each ;
|
||||
|
||||
M: #shuffle convert* drop ;
|
||||
|
||||
M: #>r convert* drop ;
|
||||
|
||||
M: #r> convert* drop ;
|
||||
|
||||
M: node convert
|
||||
[ load-inputs ]
|
||||
[ convert* ]
|
||||
[ store-outputs ]
|
||||
tri ;
|
||||
: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
|
||||
|
||||
: (emit-call) ( word -- )
|
||||
begin-basic-block %call emit begin-basic-block ;
|
||||
|
||||
: intrinsic-inputs ( node -- )
|
||||
[ load-inputs ]
|
||||
[ load-in-d ]
|
||||
[ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
|
||||
bi ;
|
||||
|
||||
: intrinsic-outputs ( node -- )
|
||||
[ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
|
||||
[ store-outputs ]
|
||||
[ store-out-d ]
|
||||
bi ;
|
||||
|
||||
: intrinsic ( node quot -- )
|
||||
|
|
@ -132,19 +113,17 @@ M: node convert
|
|||
tri
|
||||
] with-scope ; inline
|
||||
|
||||
USING: kernel.private math.private slots.private
|
||||
optimizer.allot ;
|
||||
USING: kernel.private math.private slots.private ;
|
||||
|
||||
: maybe-emit-fixnum-shift-fast ( node -- node )
|
||||
dup dup in-d>> second node-literal? [
|
||||
dup dup in-d>> second node-literal
|
||||
dup dup in-d>> second node-value-info literal>> dup fixnum? [
|
||||
'[ , emit-fixnum-shift-fast ] intrinsic
|
||||
] [
|
||||
dup param>> (emit-call)
|
||||
drop dup word>> (emit-call)
|
||||
] if ;
|
||||
|
||||
: emit-call ( node -- )
|
||||
dup param>> {
|
||||
dup word>> {
|
||||
{ \ tag [ [ emit-tag ] intrinsic ] }
|
||||
|
||||
{ \ slot [ [ dup emit-slot ] intrinsic ] }
|
||||
|
|
@ -175,24 +154,43 @@ optimizer.allot ;
|
|||
{ \ float> [ [ emit-float> ] intrinsic ] }
|
||||
{ \ float? [ [ emit-float= ] intrinsic ] }
|
||||
|
||||
{ \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
|
||||
{ \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
|
||||
{ \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
|
||||
! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
|
||||
! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
|
||||
! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
|
||||
|
||||
[ (emit-call) ]
|
||||
} case drop ;
|
||||
|
||||
M: #call convert emit-call ;
|
||||
|
||||
M: #call-label convert
|
||||
dup param>> loop-nesting get at [
|
||||
basic-block get successors>> push
|
||||
end-basic-block
|
||||
basic-block off
|
||||
drop
|
||||
] [
|
||||
(emit-call)
|
||||
] if* ;
|
||||
: emit-call-loop ( #recursive -- )
|
||||
dup label>> loop-nesting get at basic-block get successors>> push
|
||||
end-basic-block
|
||||
basic-block off
|
||||
drop ;
|
||||
|
||||
: emit-call-recursive ( #recursive -- )
|
||||
label>> id>> (emit-call) ;
|
||||
|
||||
M: #call-recursive convert
|
||||
dup label>> loop?>>
|
||||
[ emit-call-loop ] [ emit-call-recursive ] if ;
|
||||
|
||||
M: #push convert
|
||||
[
|
||||
[ out-d>> first produce-vreg ]
|
||||
[ node-output-infos first literal>> ]
|
||||
bi emit-literal
|
||||
]
|
||||
[ store-out-d ] bi ;
|
||||
|
||||
M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
|
||||
|
||||
M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
|
||||
|
||||
M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
|
||||
|
||||
M: #terminate convert drop ;
|
||||
|
||||
: integer-conditional ( in1 in2 cc -- )
|
||||
[ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
|
||||
|
|
@ -221,50 +219,38 @@ M: #call-label convert
|
|||
[ set-basic-block ]
|
||||
bi ;
|
||||
|
||||
: phi-inputs ( #if -- vregs-seq )
|
||||
children>>
|
||||
[ last-node ] map
|
||||
[ #values? ] filter
|
||||
[ in-d>> [ value>vreg ] map ] map ;
|
||||
|
||||
: phi-outputs ( #if -- vregs )
|
||||
successor>> out-d>> [ produce-vreg ] map ;
|
||||
|
||||
: emit-phi ( #if -- )
|
||||
[ phi-outputs ] [ phi-inputs ] bi %phi emit ;
|
||||
|
||||
M: #if convert
|
||||
{
|
||||
[ load-inputs ]
|
||||
[ emit-if ]
|
||||
[ convert-if-children ]
|
||||
[ emit-phi ]
|
||||
} cleave ;
|
||||
[ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
|
||||
|
||||
M: #values convert drop ;
|
||||
M: #dispatch convert
|
||||
"Unimplemented" throw ;
|
||||
|
||||
M: #merge convert drop ;
|
||||
|
||||
M: #entry convert drop ;
|
||||
M: #phi convert drop ;
|
||||
|
||||
M: #declare convert drop ;
|
||||
|
||||
M: #terminate convert drop ;
|
||||
M: #return convert drop %return emit ;
|
||||
|
||||
M: #label convert
|
||||
#! Labels create a new procedure.
|
||||
[ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ;
|
||||
: convert-recursive ( #recursive -- )
|
||||
[ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
|
||||
[ (emit-call) ]
|
||||
bi ;
|
||||
|
||||
M: #loop convert
|
||||
#! Loops become part of the current CFG.
|
||||
begin-basic-block
|
||||
[ param>> basic-block get 2array loop-nesting get push ]
|
||||
[ node-child convert-nodes ]
|
||||
bi
|
||||
: begin-loop ( #recursive -- )
|
||||
label>> basic-block get 2array loop-nesting get push ;
|
||||
|
||||
: end-loop ( -- )
|
||||
loop-nesting get pop* ;
|
||||
|
||||
M: #return convert
|
||||
param>> loop-nesting get key? [
|
||||
%epilog emit
|
||||
%return emit
|
||||
] unless ;
|
||||
: convert-loop ( #recursive -- )
|
||||
begin-basic-block
|
||||
[ begin-loop ]
|
||||
[ child>> convert-nodes ]
|
||||
[ drop end-loop ]
|
||||
tri ;
|
||||
|
||||
M: #recursive convert
|
||||
dup label>> loop?>>
|
||||
[ convert-loop ] [ convert-recursive ] if ;
|
||||
|
||||
M: #copy convert drop ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces sequences assocs io
|
||||
prettyprint inference generator optimizer compiler.vops
|
||||
compiler.cfg.builder compiler.cfg.simplifier
|
||||
compiler.machine.builder compiler.machine.simplifier ;
|
||||
IN: compiler.machine.debug
|
||||
prettyprint inference generator optimizer
|
||||
compiler.vops
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
compiler.cfg.builder
|
||||
compiler.cfg.simplifier
|
||||
compiler.machine.builder
|
||||
compiler.machine.simplifier ;
|
||||
IN: compiler.machine.debugger
|
||||
|
||||
: dataflow>linear ( dataflow word -- linear )
|
||||
: tree>linear ( tree word -- linear )
|
||||
[
|
||||
init-counter
|
||||
build-cfg
|
||||
|
|
@ -20,15 +25,16 @@ IN: compiler.machine.debug
|
|||
] assoc-each ;
|
||||
|
||||
: linearized-quot. ( quot -- )
|
||||
dataflow optimize
|
||||
"Anonymous quotation" dataflow>linear
|
||||
build-tree optimize-tree
|
||||
"Anonymous quotation" tree>linear
|
||||
linear. ;
|
||||
|
||||
: linearized-word. ( word -- )
|
||||
dup word-dataflow nip optimize swap dataflow>linear linear. ;
|
||||
dup build-tree-from-word nip optimize-tree
|
||||
dup word-dataflow nip optimize swap tree>linear linear. ;
|
||||
|
||||
: >basic-block ( quot -- basic-block )
|
||||
dataflow optimize
|
||||
build-tree optimize-tree
|
||||
[
|
||||
init-counter
|
||||
"Anonymous quotation" build-cfg
|
||||
|
|
@ -22,6 +22,11 @@ IN: compiler.tree.builder
|
|||
] with-tree-builder nip
|
||||
unclip-last in-d>> ;
|
||||
|
||||
: build-sub-tree ( #call quot -- nodes )
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip
|
||||
build-tree-with
|
||||
rot #copy suffix ;
|
||||
|
||||
: (make-specializer) ( class picker -- quot )
|
||||
swap "predicate" word-prop append ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,61 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel sets namespaces accessors assocs
|
||||
arrays combinators continuations
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.checker
|
||||
|
||||
! Check some invariants.
|
||||
ERROR: check-use-error value message ;
|
||||
|
||||
: check-use ( value uses -- )
|
||||
[ empty? [ "No use" check-use-error ] [ drop ] if ]
|
||||
[ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
|
||||
|
||||
: check-def-use ( -- )
|
||||
def-use get [ uses>> check-use ] assoc-each ;
|
||||
|
||||
GENERIC: check-node ( node -- )
|
||||
|
||||
M: #shuffle check-node
|
||||
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
|
||||
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
|
||||
bi ;
|
||||
|
||||
: check-lengths ( seq -- )
|
||||
[ length ] map all-equal? [ "Bad lengths" throw ] unless ;
|
||||
|
||||
M: #copy check-node inputs/outputs 2array check-lengths ;
|
||||
|
||||
M: #>r check-node inputs/outputs 2array check-lengths ;
|
||||
|
||||
M: #r> check-node inputs/outputs 2array check-lengths ;
|
||||
|
||||
M: #return-recursive check-node inputs/outputs 2array check-lengths ;
|
||||
|
||||
M: #phi check-node
|
||||
{
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
|
||||
[ phi-in-d>> check-lengths ]
|
||||
[ phi-in-r>> check-lengths ]
|
||||
} cleave ;
|
||||
|
||||
M: #enter-recursive check-node
|
||||
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
|
||||
[ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
|
||||
bi ;
|
||||
|
||||
M: #push check-node
|
||||
out-d>> length 1 = [ "Bad #push" throw ] unless ;
|
||||
|
||||
M: node check-node drop ;
|
||||
|
||||
ERROR: check-node-error node error ;
|
||||
|
||||
: check-nodes ( nodes -- )
|
||||
compute-def-use
|
||||
check-def-use
|
||||
[ [ check-node ] [ check-node-error ] recover ] each-node ;
|
||||
|
|
@ -105,10 +105,10 @@ SYMBOL: live-branches
|
|||
|
||||
M: #branch cleanup*
|
||||
{
|
||||
[ live-branches>> live-branches set ]
|
||||
[ delete-unreachable-branches ]
|
||||
[ cleanup-children ]
|
||||
[ fold-only-branch ]
|
||||
[ live-branches>> live-branches set ]
|
||||
} cleave ;
|
||||
|
||||
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
|
||||
|
|
@ -122,7 +122,8 @@ M: #phi cleanup*
|
|||
[ '[ , cleanup-phi-in ] change-phi-in-r ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-d ]
|
||||
[ '[ , cleanup-phi-in ] change-phi-info-r ]
|
||||
} cleave ;
|
||||
} cleave
|
||||
live-branches off ;
|
||||
|
||||
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors namespaces assocs dequeues search-dequeues
|
||||
kernel sequences words sets stack-checker.inlining compiler.tree
|
||||
compiler.tree.def-use compiler.tree.combinators ;
|
||||
kernel sequences words sets
|
||||
stack-checker.branches stack-checker.inlining
|
||||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||
IN: compiler.tree.dataflow-analysis
|
||||
|
||||
! Dataflow analysis
|
||||
|
|
@ -34,5 +35,5 @@ SYMBOL: work-list
|
|||
: dfa ( node mark-quot iterate-quot -- assoc )
|
||||
init-dfa
|
||||
[ each-node ] dip
|
||||
work-list get H{ { f f } } clone
|
||||
work-list get H{ { +bottom+ f } } clone
|
||||
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
IN: compiler.tree.debugger.tests
|
||||
USING: compiler.tree.debugger tools.test ;
|
||||
|
||||
\ optimized-quot. must-infer
|
||||
\ optimized-word. must-infer
|
||||
\ optimizer-report. must-infer
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs fry match accessors namespaces effects
|
||||
sequences sequences.private quotations generic macros arrays
|
||||
prettyprint prettyprint.backend prettyprint.sections math words
|
||||
combinators io sorting
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.debugger
|
||||
|
||||
! A simple tool for turning tree IR into quotations and
|
||||
! printing reports, for debugging purposes.
|
||||
|
||||
GENERIC: node>quot ( node -- )
|
||||
|
||||
MACRO: match-choose ( alist -- )
|
||||
[ '[ , ] ] assoc-map '[ , match-cond ] ;
|
||||
|
||||
MATCH-VARS: ?a ?b ?c ;
|
||||
|
||||
: pretty-shuffle ( in out -- word/f )
|
||||
2array {
|
||||
{ { { } { } } [ ] }
|
||||
{ { { ?a } { ?a } } [ ] }
|
||||
{ { { ?a ?b } { ?a ?b } } [ ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
|
||||
{ { { ?a } { } } [ drop ] }
|
||||
{ { { ?a ?b } { } } [ 2drop ] }
|
||||
{ { { ?a ?b ?c } { } } [ 3drop ] }
|
||||
{ { { ?a } { ?a ?a } } [ dup ] }
|
||||
{ { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
|
||||
{ { { ?a ?b } { ?a ?b ?a } } [ over ] }
|
||||
{ { { ?b ?a } { ?a ?b } } [ swap ] }
|
||||
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
|
||||
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
|
||||
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
|
||||
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
|
||||
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
|
||||
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
|
||||
{ { { ?a ?b } { ?b } } [ nip ] }
|
||||
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
|
||||
{ _ f }
|
||||
} match-choose ;
|
||||
|
||||
TUPLE: shuffle effect ;
|
||||
|
||||
M: shuffle pprint* effect>> effect>string text ;
|
||||
|
||||
: shuffle-inputs/outputs ( node -- in out )
|
||||
[ in-d>> ] [ out-d>> ] [ mapping>> ] tri
|
||||
[ at ] curry map ;
|
||||
|
||||
M: #shuffle node>quot
|
||||
shuffle-inputs/outputs 2dup pretty-shuffle dup
|
||||
[ 2nip % ] [ drop <effect> shuffle boa , ] if ;
|
||||
|
||||
: pushed-literals ( node -- seq )
|
||||
dup out-d>> [ node-value-info literal>> literalize ] with map ;
|
||||
|
||||
M: #push node>quot pushed-literals % ;
|
||||
|
||||
M: #call node>quot word>> , ;
|
||||
|
||||
M: #call-recursive node>quot label>> id>> , ;
|
||||
|
||||
DEFER: nodes>quot
|
||||
|
||||
DEFER: label
|
||||
|
||||
M: #recursive node>quot
|
||||
[ label>> id>> literalize , ]
|
||||
[ child>> nodes>quot , \ label , ]
|
||||
bi ;
|
||||
|
||||
M: #if node>quot
|
||||
children>> [ nodes>quot ] map % \ if , ;
|
||||
|
||||
M: #dispatch node>quot
|
||||
children>> [ nodes>quot ] map , \ dispatch , ;
|
||||
|
||||
M: #>r node>quot in-d>> length \ >r <repetition> % ;
|
||||
|
||||
M: #r> node>quot out-d>> length \ r> <repetition> % ;
|
||||
|
||||
M: node node>quot drop ;
|
||||
|
||||
: nodes>quot ( node -- quot )
|
||||
[ [ node>quot ] each ] [ ] make ;
|
||||
|
||||
: optimized. ( quot/word -- )
|
||||
dup word? [ specialized-def ] when
|
||||
build-tree optimize-tree nodes>quot . ;
|
||||
|
||||
SYMBOL: words-called
|
||||
SYMBOL: generics-called
|
||||
SYMBOL: methods-called
|
||||
SYMBOL: intrinsics-called
|
||||
SYMBOL: node-count
|
||||
|
||||
: make-report ( word/quot -- assoc )
|
||||
[
|
||||
dup word? [ build-tree-from-word nip ] [ build-tree ] if
|
||||
optimize-tree
|
||||
|
||||
H{ } clone words-called set
|
||||
H{ } clone generics-called set
|
||||
H{ } clone methods-called set
|
||||
H{ } clone intrinsics-called set
|
||||
|
||||
0 swap [
|
||||
>r 1+ r>
|
||||
dup #call? [
|
||||
word>> {
|
||||
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
|
||||
{ [ dup generic? ] [ generics-called ] }
|
||||
{ [ dup method-body? ] [ methods-called ] }
|
||||
[ words-called ]
|
||||
} cond 1 -rot get at+
|
||||
] [ drop ] if
|
||||
] each-node
|
||||
node-count set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: report. ( report -- )
|
||||
[
|
||||
"==== Total number of IR nodes:" print
|
||||
node-count get .
|
||||
|
||||
{
|
||||
{ generics-called "==== Generic word calls:" }
|
||||
{ words-called "==== Ordinary word calls:" }
|
||||
{ methods-called "==== Non-inlined method calls:" }
|
||||
{ intrinsics-called "==== Open-coded intrinsic calls:" }
|
||||
} [
|
||||
nl print get keys natural-sort stack.
|
||||
] assoc-each
|
||||
] bind ;
|
||||
|
||||
: optimizer-report. ( word -- )
|
||||
make-report report. ;
|
||||
|
|
@ -1,7 +1,9 @@
|
|||
USING: accessors namespaces assocs kernel sequences math
|
||||
tools.test words sets combinators.short-circuit
|
||||
stack-checker.state compiler.tree compiler.tree.builder
|
||||
compiler.tree.def-use arrays kernel.private ;
|
||||
compiler.tree.normalization compiler.tree.propagation
|
||||
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
|
||||
sorting math.order binary-search compiler.tree.checker ;
|
||||
IN: compiler.tree.def-use.tests
|
||||
|
||||
\ compute-def-use must-infer
|
||||
|
|
@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
|
|||
} 1&&
|
||||
] unit-test
|
||||
|
||||
! compute-def-use checks for SSA violations, so we make sure
|
||||
! some common patterns are generated correctly.
|
||||
: test-def-use ( quot -- )
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
compute-def-use
|
||||
check-nodes ;
|
||||
|
||||
! compute-def-use checks for SSA violations, so we use that to
|
||||
! ensure we generate some common patterns correctly.
|
||||
{
|
||||
[ [ drop ] each-integer ]
|
||||
[ [ 2drop ] curry each-integer ]
|
||||
|
|
@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
|
|||
[ [ 1 ] 2 [ + ] curry compose call + ]
|
||||
[ [ 1 ] [ call 2 ] curry call + ]
|
||||
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
|
||||
[ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
|
||||
[ dup [ drop f ] [ "A" throw ] if ]
|
||||
[ [ <=> ] sort ]
|
||||
[ [ <=> ] with search ]
|
||||
} [
|
||||
[ ] swap [ build-tree compute-def-use drop ] curry unit-test
|
||||
[ ] swap [ test-def-use ] curry unit-test
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays namespaces assocs sequences kernel generic assocs
|
||||
classes vectors accessors combinators sets stack-checker.state
|
||||
compiler.tree compiler.tree.combinators ;
|
||||
classes vectors accessors combinators sets
|
||||
stack-checker.state
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.def-use
|
||||
|
||||
SYMBOL: def-use
|
||||
|
|
@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
|
|||
M: #push node-uses-values drop f ;
|
||||
M: #r> node-uses-values in-r>> ;
|
||||
M: #phi node-uses-values
|
||||
[ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
|
||||
[ phi-in-d>> ] [ phi-in-r>> ] bi
|
||||
append concat remove-bottom prune ;
|
||||
M: #declare node-uses-values declaration>> keys ;
|
||||
M: node node-uses-values in-d>> ;
|
||||
|
||||
|
|
@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
|
|||
[ dup node-uses-values [ use-value ] with each ]
|
||||
[ dup node-defs-values [ def-value ] with each ] bi ;
|
||||
|
||||
: check-use ( uses -- )
|
||||
[ empty? [ "No use" throw ] when ]
|
||||
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
|
||||
|
||||
: check-def-use ( -- )
|
||||
def-use get [ nip uses>> check-use ] assoc-each ;
|
||||
|
||||
: compute-def-use ( node -- node )
|
||||
H{ } clone def-use set
|
||||
dup [ node-def-use ] each-node
|
||||
check-def-use ;
|
||||
dup [ node-def-use ] each-node ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
|
|||
IN: compiler.tree.escape-analysis.branches
|
||||
|
||||
M: #branch escape-analysis*
|
||||
live-children sift [ (escape-analysis) ] each ;
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ live-children sift [ (escape-analysis) ] each ]
|
||||
bi ;
|
||||
|
||||
: (merge-allocations) ( values -- allocation )
|
||||
[
|
||||
|
|
@ -25,7 +27,7 @@ M: #branch escape-analysis*
|
|||
] map ;
|
||||
|
||||
: merge-allocations ( in-values out-values -- )
|
||||
[ [ sift ] map ] dip
|
||||
[ [ remove-bottom ] map ] dip
|
||||
[ [ merge-values ] 2each ]
|
||||
[ [ (merge-allocations) ] dip record-allocations ]
|
||||
2bi ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
|
|||
compiler.tree.propagation compiler.tree.cleanup
|
||||
compiler.tree.combinators compiler.tree sequences math math.private
|
||||
kernel tools.test accessors slots.private quotations.private
|
||||
prettyprint classes.tuple.private classes classes.tuple ;
|
||||
prettyprint classes.tuple.private classes classes.tuple
|
||||
compiler.tree.intrinsics ;
|
||||
|
||||
\ escape-analysis must-infer
|
||||
|
||||
|
|
@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
|
|||
out-d>> first escaping-allocation? [ 1+ ] unless ;
|
||||
|
||||
M: #call count-unboxed-allocations*
|
||||
dup word>> { <tuple-boa> <complex> } memq?
|
||||
dup word>> { <immutable-tuple-boa> <complex> } memq?
|
||||
[ (count-unboxed-allocations) ] [ drop ] if ;
|
||||
|
||||
M: #push count-unboxed-allocations*
|
||||
|
|
|
|||
|
|
@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
} cond ;
|
||||
|
||||
: check-fixed-point ( node alloc1 alloc2 -- )
|
||||
[ congruent? ] 2all? [ drop ] [
|
||||
label>> f >>fixed-point drop
|
||||
] if ;
|
||||
[ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
|
||||
|
||||
: node-input-allocations ( node -- allocations )
|
||||
in-d>> [ allocation ] map ;
|
||||
|
|
@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
] 2bi ;
|
||||
|
||||
M: #recursive escape-analysis* ( #recursive -- )
|
||||
[
|
||||
{ 0 } clone [ USE: math
|
||||
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
|
||||
child>>
|
||||
[ first out-d>> introduce-values ]
|
||||
[ first analyze-recursive-phi ]
|
||||
[ (escape-analysis) ]
|
||||
tri
|
||||
] until-fixed-point ;
|
||||
] curry until-fixed-point ;
|
||||
|
||||
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
|
||||
#! Handled by #recursive
|
||||
|
|
|
|||
|
|
@ -33,8 +33,10 @@ DEFER: record-literal-allocation
|
|||
} cond ;
|
||||
|
||||
: record-literal-allocation ( value object -- )
|
||||
object-slots dup
|
||||
[ make-literal-slots swap record-allocation ] [ 2drop ] if ;
|
||||
object-slots
|
||||
[ make-literal-slots swap record-allocation ]
|
||||
[ unknown-allocation ]
|
||||
if* ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
#! Delegation.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,26 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ;
|
||||
USING: kernel classes.tuple classes.tuple.private math arrays
|
||||
byte-arrays words stack-checker.known-words ;
|
||||
IN: compiler.tree.intrinsics
|
||||
|
||||
: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
|
||||
: <immutable-tuple-boa> ( ... class -- tuple )
|
||||
"BUG: missing <immutable-tuple-boa> intrinsic" throw ;
|
||||
|
||||
: (tuple) ( layout -- tuple )
|
||||
"BUG: missing (tuple) intrinsic" throw ;
|
||||
|
||||
\ (tuple) { tuple-layout } { tuple } define-primitive
|
||||
\ (tuple) make-flushable
|
||||
|
||||
: (array) ( n -- array )
|
||||
"BUG: missing (array) intrinsic" throw ;
|
||||
|
||||
\ (array) { integer } { array } define-primitive
|
||||
\ (array) make-flushable
|
||||
|
||||
: (byte-array) ( n -- byte-array )
|
||||
"BUG: missing (byte-array) intrinsic" throw ;
|
||||
|
||||
\ (byte-array) { integer } { byte-array } define-primitive
|
||||
\ (byte-array) make-flushable
|
||||
|
|
|
|||
|
|
@ -0,0 +1,150 @@
|
|||
IN: compiler.tree.loop.detection.tests
|
||||
USING: compiler.tree.loop.detection tools.test
|
||||
kernel combinators.short-circuit math sequences accessors
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.combinators ;
|
||||
|
||||
[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
|
||||
[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
|
||||
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
|
||||
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
|
||||
|
||||
\ detect-loops must-infer
|
||||
|
||||
: label-is-loop? ( nodes word -- ? )
|
||||
[
|
||||
{
|
||||
[ drop #recursive? ]
|
||||
[ drop label>> loop?>> ]
|
||||
[ swap label>> word>> eq? ]
|
||||
} 2&&
|
||||
] curry contains-node? ;
|
||||
|
||||
\ label-is-loop? must-infer
|
||||
|
||||
: label-is-not-loop? ( nodes word -- ? )
|
||||
[
|
||||
{
|
||||
[ drop #recursive? ]
|
||||
[ drop label>> loop?>> not ]
|
||||
[ swap label>> word>> eq? ]
|
||||
} 2&&
|
||||
] curry contains-node? ;
|
||||
|
||||
\ label-is-not-loop? must-infer
|
||||
|
||||
: loop-test-1 ( a -- )
|
||||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 ] build-tree detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 1 2 3 ] build-tree detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] build-tree detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ [ loop-test-1 ] each ] build-tree detect-loops
|
||||
\ (each-integer) label-is-loop?
|
||||
] unit-test
|
||||
|
||||
: loop-test-2 ( a -- )
|
||||
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-2 ] build-tree detect-loops
|
||||
\ loop-test-2 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
: loop-test-3 ( a -- )
|
||||
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-3 ] build-tree detect-loops
|
||||
\ loop-test-3 label-is-not-loop?
|
||||
] unit-test
|
||||
|
||||
: loop-test-4 ( a -- )
|
||||
dup [
|
||||
loop-test-4
|
||||
] [
|
||||
drop
|
||||
] if ; inline recursive
|
||||
|
||||
[ f ] [
|
||||
[ [ [ ] map ] map ] build-tree detect-loops
|
||||
[
|
||||
dup #recursive? [ label>> loop?>> not ] [ drop f ] if
|
||||
] contains-node?
|
||||
] unit-test
|
||||
|
||||
: blah f ;
|
||||
|
||||
DEFER: a
|
||||
|
||||
: b ( -- )
|
||||
blah [ b ] [ a ] if ; inline recursive
|
||||
|
||||
: a ( -- )
|
||||
blah [ b ] [ a ] if ; inline recursive
|
||||
|
||||
[ t ] [
|
||||
[ a ] build-tree detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] build-tree detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ b ] build-tree detect-loops
|
||||
\ a label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ a ] build-tree detect-loops
|
||||
\ b label-is-loop?
|
||||
] unit-test
|
||||
|
||||
DEFER: a'
|
||||
|
||||
: b' ( -- )
|
||||
blah [ b' b' ] [ a' ] if ; inline recursive
|
||||
|
||||
: a' ( -- )
|
||||
blah [ b' ] [ a' ] if ; inline recursive
|
||||
|
||||
[ f ] [
|
||||
[ a' ] build-tree detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ b' ] build-tree detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
! I used to think this should be f, but doing this on pen and
|
||||
! paper almost convinced me that a loop conversion here is
|
||||
! sound.
|
||||
|
||||
[ t ] [
|
||||
[ b' ] build-tree detect-loops
|
||||
\ a' label-is-loop?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ a' ] build-tree detect-loops
|
||||
\ b' label-is-loop?
|
||||
] unit-test
|
||||
|
|
@ -1,5 +1,88 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.loop-detection
|
||||
USING: kernel sequences namespaces assocs accessors fry
|
||||
compiler.tree dequeues search-dequeues ;
|
||||
IN: compiler.tree.loop.detection
|
||||
|
||||
: detect-loops ( nodes -- nodes' ) ;
|
||||
! A loop is a #recursive which only tail calls itself, and those
|
||||
! calls are nested inside other loops only. We optimistically
|
||||
! assume all #recursive nodes are loops, disqualifying them as
|
||||
! we see evidence to the contrary.
|
||||
|
||||
: (tail-calls) ( tail? seq -- seq' )
|
||||
reverse [ swap [ and ] keep ] map nip reverse ;
|
||||
|
||||
: tail-calls ( tail? node -- seq )
|
||||
[
|
||||
[ #phi? ]
|
||||
[ #return? ]
|
||||
[ #return-recursive? ]
|
||||
tri or or
|
||||
] map (tail-calls) ;
|
||||
|
||||
SYMBOL: loop-heights
|
||||
SYMBOL: loop-calls
|
||||
SYMBOL: loop-stack
|
||||
SYMBOL: work-list
|
||||
|
||||
GENERIC: collect-loop-info* ( tail? node -- )
|
||||
|
||||
: non-tail-label-info ( nodes -- )
|
||||
[ f swap collect-loop-info* ] each ;
|
||||
|
||||
: (collect-loop-info) ( tail? nodes -- )
|
||||
[ tail-calls ] keep [ collect-loop-info* ] 2each ;
|
||||
|
||||
: remember-loop-info ( label -- )
|
||||
loop-stack get length swap loop-heights get set-at ;
|
||||
|
||||
M: #recursive collect-loop-info*
|
||||
nip
|
||||
[
|
||||
[
|
||||
label>>
|
||||
[ loop-stack [ swap suffix ] change ]
|
||||
[ remember-loop-info ]
|
||||
[ t >>loop? drop ]
|
||||
tri
|
||||
]
|
||||
[ t swap child>> (collect-loop-info) ] bi
|
||||
] with-scope ;
|
||||
|
||||
: current-loop-nesting ( label -- labels )
|
||||
loop-stack get swap loop-heights get at tail ;
|
||||
|
||||
: disqualify-loop ( label -- )
|
||||
work-list get push-front ;
|
||||
|
||||
M: #call-recursive collect-loop-info*
|
||||
label>>
|
||||
swap [ dup disqualify-loop ] unless
|
||||
dup current-loop-nesting [ loop-calls get push-at ] with each ;
|
||||
|
||||
M: #if collect-loop-info*
|
||||
children>> [ (collect-loop-info) ] with each ;
|
||||
|
||||
M: #dispatch collect-loop-info*
|
||||
children>> [ (collect-loop-info) ] with each ;
|
||||
|
||||
M: node collect-loop-info* 2drop ;
|
||||
|
||||
: collect-loop-info ( node -- )
|
||||
{ } loop-stack set
|
||||
H{ } clone loop-calls set
|
||||
H{ } clone loop-heights set
|
||||
<hashed-dlist> work-list set
|
||||
t swap (collect-loop-info) ;
|
||||
|
||||
: disqualify-loops ( -- )
|
||||
work-list get [
|
||||
dup loop?>> [
|
||||
[ f >>loop? drop ]
|
||||
[ loop-calls get at [ disqualify-loop ] each ]
|
||||
bi
|
||||
] [ drop ] if
|
||||
] slurp-dequeue ;
|
||||
|
||||
: detect-loops ( nodes -- nodes )
|
||||
dup collect-loop-info disqualify-loops ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.elaboration
|
||||
IN: compiler.tree.loop.inversion
|
||||
|
||||
: elaborate ( nodes -- nodes' ) ;
|
||||
: invert-loops ( nodes -- nodes' ) ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
IN: compiler.tree.normalization.tests
|
||||
USING: compiler.tree.builder compiler.tree.normalization
|
||||
compiler.tree sequences accessors tools.test kernel ;
|
||||
compiler.tree sequences accessors tools.test kernel math ;
|
||||
|
||||
\ count-introductions must-infer
|
||||
\ fixup-enter-recursive must-infer
|
||||
|
|
@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
|
|||
[ recursive-inputs ]
|
||||
[ normalize recursive-inputs ] bi
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry namespaces sequences math accessors kernel arrays
|
||||
stack-checker.backend stack-checker.inlining compiler.tree
|
||||
stack-checker.backend
|
||||
stack-checker.branches
|
||||
stack-checker.inlining
|
||||
compiler.tree
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.normalization
|
||||
|
||||
|
|
@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
|
|||
bi ;
|
||||
|
||||
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
||||
[ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
|
||||
[ flip ] dip [
|
||||
[ nip ] [
|
||||
dup [ +bottom+ eq? ] left-trim
|
||||
[ [ length ] bi@ - tail* ] keep append
|
||||
] if
|
||||
] 3map flip ;
|
||||
|
||||
M: #phi eliminate-introductions*
|
||||
remaining-introductions get swap dup terminated>>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: compiler.tree.optimizer tools.test ;
|
||||
IN: compiler.tree.optimizer.tests
|
||||
|
||||
\ optimize-tree must-infer
|
||||
|
|
@ -8,7 +8,8 @@ compiler.tree.tuple-unboxing
|
|||
compiler.tree.def-use
|
||||
compiler.tree.dead-code
|
||||
compiler.tree.strength-reduction
|
||||
compiler.tree.loop-detection
|
||||
compiler.tree.loop.detection
|
||||
compiler.tree.loop.inversion
|
||||
compiler.tree.branch-fusion ;
|
||||
IN: compiler.tree.optimizer
|
||||
|
||||
|
|
@ -16,11 +17,11 @@ IN: compiler.tree.optimizer
|
|||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
detect-loops
|
||||
invert-loops
|
||||
fuse-branches
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
remove-dead-code
|
||||
strength-reduce
|
||||
detect-loops
|
||||
fuse-branches
|
||||
elaborate ;
|
||||
strength-reduce ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry kernel sequences assocs accessors namespaces
|
||||
math.intervals arrays classes.algebra combinators
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators
|
||||
|
|
@ -59,7 +60,14 @@ SYMBOL: infer-children-data
|
|||
|
||||
: compute-phi-input-infos ( phi-in -- phi-info )
|
||||
infer-children-data get
|
||||
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
|
||||
'[
|
||||
, [
|
||||
[
|
||||
dup +bottom+ eq?
|
||||
[ drop null-info ] [ value-info ] if
|
||||
] bind
|
||||
] 2map
|
||||
] map ;
|
||||
|
||||
: annotate-phi-inputs ( #phi -- )
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
|
||||
|
|
@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
|
|||
M: #phi propagate-after ( #phi -- )
|
||||
condition-value get [
|
||||
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
|
||||
3array flip [
|
||||
first3 [ possible-boolean-values ] map
|
||||
[
|
||||
[ possible-boolean-values ] map
|
||||
branch-phi-constraints
|
||||
] each
|
||||
] 3each
|
||||
] [ drop ] if ;
|
||||
|
||||
M: #phi propagate-around ( #phi -- )
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences assocs math kernel accessors fry
|
||||
combinators sets locals
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
|
|
@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
|
|||
#! An output is a copy of every input if all inputs are
|
||||
#! copies of the same original value.
|
||||
[
|
||||
swap sift [ resolve-copy ] map
|
||||
swap remove-bottom [ resolve-copy ] map
|
||||
dup [ all-equal? ] [ empty? not ] bi and
|
||||
[ first swap is-copy-of ] [ 2drop ] if
|
||||
] 2each ;
|
||||
|
|
|
|||
|
|
@ -18,10 +18,7 @@ M: word splicing-nodes
|
|||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||
|
||||
M: quotation splicing-nodes
|
||||
[ [ out-d>> ] [ in-d>> ] bi ] dip
|
||||
build-tree-with
|
||||
rot #copy suffix
|
||||
normalize ;
|
||||
build-sub-tree normalize ;
|
||||
|
||||
: propagate-body ( #call -- )
|
||||
body>> (propagate) ;
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
|
|||
: unify-recursive-stacks ( stacks initial -- infos )
|
||||
over empty? [ nip ] [
|
||||
[
|
||||
[ sift value-infos-union ] dip
|
||||
[ value-infos-union ] dip
|
||||
[ generalize-counter ] keep
|
||||
value-info-union
|
||||
] 2map
|
||||
|
|
|
|||
|
|
@ -1,24 +1,22 @@
|
|||
IN: compiler.tree.tuple-unboxing.tests
|
||||
USING: tools.test compiler.tree.tuple-unboxing
|
||||
compiler.tree compiler.tree.builder compiler.tree.normalization
|
||||
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
|
||||
compiler.tree.builder compiler.tree.normalization
|
||||
compiler.tree.propagation compiler.tree.cleanup
|
||||
compiler.tree.escape-analysis compiler.tree.tuple-unboxing
|
||||
compiler.tree.def-use kernel accessors sequences math
|
||||
sorting math.order binary-search ;
|
||||
compiler.tree.checker compiler.tree.def-use kernel accessors
|
||||
sequences math math.private sorting math.order binary-search
|
||||
sequences.private slots.private ;
|
||||
|
||||
\ unbox-tuples must-infer
|
||||
|
||||
: test-unboxing ( quot -- )
|
||||
#! Just make sure it doesn't throw errors; compute def use
|
||||
#! for kicks.
|
||||
build-tree
|
||||
normalize
|
||||
propagate
|
||||
cleanup
|
||||
escape-analysis
|
||||
unbox-tuples
|
||||
compute-def-use
|
||||
drop ;
|
||||
check-nodes ;
|
||||
|
||||
TUPLE: cons { car read-only } { cdr read-only } ;
|
||||
|
||||
|
|
@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
|
|||
[ cons boa [ car>> ] [ cdr>> ] bi ]
|
||||
[ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
|
||||
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
|
||||
[ 2 cons boa { [ ] [ ] } dispatch ]
|
||||
[ dup [ drop f ] [ "A" throw ] if ]
|
||||
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
|
||||
[ [ ] [ ] curry curry call ]
|
||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
[ [ <=> ] sort ]
|
||||
[ [ <=> ] with search ]
|
||||
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: namespaces assocs accessors kernel combinators
|
||||
classes.algebra sequences sequences.deep slots.private
|
||||
classes.tuple.private math math.private arrays
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.intrinsics
|
||||
compiler.tree.combinators
|
||||
|
|
@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
: flatten-values ( values -- values' )
|
||||
(flatten-values) flatten ;
|
||||
|
||||
: flatten-value ( values -- values )
|
||||
[ unboxed-allocation ] [ 1array ] bi or ;
|
||||
|
||||
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
|
||||
[ in-d>> first flatten-value ]
|
||||
[ in-d>> flatten-values ]
|
||||
[ out-d>> flatten-values ]
|
||||
[
|
||||
out-d>> first slot-accesses get at
|
||||
[ slot#>> ] [ value>> ] bi allocation nth flatten-value
|
||||
[ slot#>> ] [ value>> ] bi allocation nth
|
||||
1array flatten-values
|
||||
] tri ;
|
||||
|
||||
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
|
||||
|
|
@ -73,7 +72,8 @@ M: #call unbox-tuples*
|
|||
} case ;
|
||||
|
||||
M: #declare unbox-tuples*
|
||||
[ unzip [ flatten-values ] dip zip ] change-declaration ;
|
||||
#! We don't look at declarations after propagation anyway.
|
||||
f >>declaration ;
|
||||
|
||||
M: #copy unbox-tuples*
|
||||
[ flatten-values ] change-in-d
|
||||
|
|
@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
|
|||
[ flatten-values ] change-in-d ;
|
||||
|
||||
M: #phi unbox-tuples*
|
||||
[ flip [ flatten-values ] map flip ] change-phi-in-d
|
||||
[ flip [ flatten-values ] map flip ] change-phi-in-r
|
||||
[ flatten-values ] change-out-d
|
||||
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
|
||||
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
|
||||
[ flatten-values ] change-out-d
|
||||
[ flatten-values ] change-out-r ;
|
||||
|
||||
M: #recursive unbox-tuples*
|
||||
|
|
|
|||
|
|
@ -9,21 +9,30 @@ IN: stack-checker.branches
|
|||
: balanced? ( pairs -- ? )
|
||||
[ second ] filter [ first2 length - ] map all-equal? ;
|
||||
|
||||
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
|
||||
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
|
||||
SYMBOL: +bottom+
|
||||
|
||||
: pad-with-f ( seq -- newseq )
|
||||
dup [ length ] map supremum '[ , f pad-left ] map ;
|
||||
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
|
||||
dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
|
||||
|
||||
: pad-with-bottom ( seq -- newseq )
|
||||
dup empty? [
|
||||
dup [ length ] map supremum
|
||||
'[ , +bottom+ pad-left ] map
|
||||
] unless ;
|
||||
|
||||
: phi-inputs ( max-d-in pairs -- newseq )
|
||||
dup empty? [ nip ] [
|
||||
swap '[ , _ first2 unify-inputs ] map
|
||||
pad-with-f
|
||||
pad-with-bottom
|
||||
flip
|
||||
] if ;
|
||||
|
||||
: remove-bottom ( seq -- seq' )
|
||||
+bottom+ swap remove ;
|
||||
|
||||
: unify-values ( values -- phi-out )
|
||||
sift dup empty? [ drop <value> ] [
|
||||
remove-bottom
|
||||
dup empty? [ drop <value> ] [
|
||||
[ known ] map dup all-eq?
|
||||
[ first make-known ] [ drop <value> ] if
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -17,15 +17,21 @@ IN: stack-checker.inlining
|
|||
: (inline-word) ( word label -- )
|
||||
[ [ def>> ] keep ] dip infer-quot-recursive ;
|
||||
|
||||
TUPLE: inline-recursive
|
||||
TUPLE: inline-recursive < identity-tuple
|
||||
id
|
||||
word
|
||||
enter-out enter-recursive
|
||||
return calls
|
||||
fixed-point
|
||||
introductions ;
|
||||
introductions
|
||||
loop? ;
|
||||
|
||||
M: inline-recursive hashcode* id>> hashcode* ;
|
||||
|
||||
: <inline-recursive> ( word -- label )
|
||||
inline-recursive new swap >>word ;
|
||||
inline-recursive new
|
||||
gensym >>id
|
||||
swap >>word ;
|
||||
|
||||
: quotation-param? ( obj -- ? )
|
||||
dup pair? [ second effect? ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -165,24 +165,27 @@ M: object infer-call*
|
|||
{ call execute dispatch load-locals get-local drop-locals }
|
||||
[ t "no-compile" set-word-prop ] each
|
||||
|
||||
SYMBOL: +primitive+
|
||||
|
||||
: non-inline-word ( word -- )
|
||||
dup +called+ depends-on
|
||||
{
|
||||
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
|
||||
{ [ dup +special+ word-prop ] [ infer-special ] }
|
||||
{ [ dup primitive? ] [ infer-primitive ] }
|
||||
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
|
||||
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
|
||||
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
||||
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
|
||||
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
||||
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
||||
{ [ dup recursive-label ] [ call-recursive-word ] }
|
||||
[ dup infer-word apply-word/effect ]
|
||||
} cond ;
|
||||
|
||||
: define-primitive ( word inputs outputs -- )
|
||||
[ 2drop t +primitive+ set-word-prop ]
|
||||
[ drop "input-classes" set-word-prop ]
|
||||
[ nip "default-output-classes" set-word-prop ]
|
||||
3bi ;
|
||||
3tri ;
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ fixnum< { fixnum fixnum } { object } define-primitive
|
||||
|
|
|
|||
|
|
@ -11,31 +11,45 @@ IN: stack-checker.transforms
|
|||
SYMBOL: +transform-quot+
|
||||
SYMBOL: +transform-n+
|
||||
|
||||
: (apply-transform) ( quot n -- newquot )
|
||||
dup zero? [
|
||||
drop recursive-state get 1array
|
||||
] [
|
||||
consume-d
|
||||
[ #drop, ]
|
||||
[ [ literal value>> ] map ]
|
||||
[ first literal recursion>> ] tri prefix
|
||||
] if
|
||||
swap with-datastack ;
|
||||
: give-up-transform ( word -- )
|
||||
dup recursive-label
|
||||
[ call-recursive-word ]
|
||||
[ dup infer-word apply-word/effect ]
|
||||
if ;
|
||||
|
||||
: ((apply-transform)) ( word quot stack -- )
|
||||
swap with-datastack first2
|
||||
dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
|
||||
inline
|
||||
|
||||
: (apply-transform) ( word quot n -- )
|
||||
consume-d dup [ known literal? ] all? [
|
||||
dup empty? [
|
||||
drop recursive-state get 1array
|
||||
] [
|
||||
[ #drop, ]
|
||||
[ [ literal value>> ] map ]
|
||||
[ first literal recursion>> ] tri prefix
|
||||
] if
|
||||
((apply-transform))
|
||||
] [ 2drop give-up-transform ] if ;
|
||||
|
||||
: apply-transform ( word -- )
|
||||
[ +inlined+ depends-on ] [
|
||||
[ ]
|
||||
[ +transform-quot+ word-prop ]
|
||||
[ +transform-n+ word-prop ]
|
||||
bi (apply-transform)
|
||||
first2 swap infer-quot
|
||||
tri
|
||||
(apply-transform)
|
||||
] bi ;
|
||||
|
||||
: apply-macro ( word -- )
|
||||
[ +inlined+ depends-on ] [
|
||||
[ ]
|
||||
[ "macro" word-prop ]
|
||||
[ "declared-effect" word-prop in>> length ]
|
||||
bi (apply-transform)
|
||||
first2 swap infer-quot
|
||||
tri
|
||||
(apply-transform)
|
||||
] bi ;
|
||||
|
||||
: define-transform ( word quot n -- )
|
||||
|
|
@ -66,20 +80,80 @@ SYMBOL: +transform-n+
|
|||
|
||||
\ spread [ spread>quot ] 1 define-transform
|
||||
|
||||
\ (call-next-method) [
|
||||
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
||||
] 2 define-transform
|
||||
|
||||
! Constructors
|
||||
\ boa [
|
||||
dup tuple-class? [
|
||||
dup +inlined+ depends-on
|
||||
[ "boa-check" word-prop ]
|
||||
[ tuple-layout '[ , <tuple-boa> ] ]
|
||||
bi append
|
||||
] [
|
||||
\ boa \ no-method boa time-bomb
|
||||
] if
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
\ (call-next-method) [
|
||||
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
||||
] 2 define-transform
|
||||
\ new [
|
||||
dup tuple-class? [
|
||||
dup +inlined+ depends-on
|
||||
dup all-slots rest-slice ! delegate slot
|
||||
[ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Membership testing
|
||||
: bit-member-n 256 ; inline
|
||||
|
||||
: bit-member? ( seq -- ? )
|
||||
#! Can we use a fast byte array test here?
|
||||
{
|
||||
{ [ dup length 8 < ] [ f ] }
|
||||
{ [ dup [ integer? not ] contains? ] [ f ] }
|
||||
{ [ dup [ 0 < ] contains? ] [ f ] }
|
||||
{ [ dup [ bit-member-n >= ] contains? ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
: bit-member-seq ( seq -- flags )
|
||||
bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
|
||||
|
||||
: exact-float? ( f -- ? )
|
||||
dup float? [ dup >integer >float = ] [ drop f ] if ; inline
|
||||
|
||||
: bit-member-quot ( seq -- newquot )
|
||||
[
|
||||
[ drop ] % ! drop the sequence itself; we don't use it at run time
|
||||
bit-member-seq ,
|
||||
[
|
||||
{
|
||||
{ [ over fixnum? ] [ ?nth 1 eq? ] }
|
||||
{ [ over bignum? ] [ ?nth 1 eq? ] }
|
||||
{ [ over exact-float? ] [ ?nth 1 eq? ] }
|
||||
[ 2drop f ]
|
||||
} cond
|
||||
] %
|
||||
] [ ] make ;
|
||||
|
||||
: member-quot ( seq -- newquot )
|
||||
dup bit-member? [
|
||||
bit-member-quot
|
||||
] [
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip case ] curry
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
dup sequence? [ member-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
: memq-quot ( seq -- newquot )
|
||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip cond ] curry ;
|
||||
|
||||
\ memq? [
|
||||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Deprecated
|
||||
\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform
|
||||
|
|
|
|||
Loading…
Reference in New Issue