Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
3cabf3aeca
|
|
@ -13,6 +13,7 @@ circular strings ;
|
|||
|
||||
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test
|
||||
[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
|
||||
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@ M: circular virtual-seq seq>> ;
|
|||
circular-wrap (>>start) ;
|
||||
|
||||
: rotate-circular ( circular -- )
|
||||
[ start>> 1 + ] keep circular-wrap (>>start) ;
|
||||
[ 1 ] dip change-circular-start ;
|
||||
|
||||
: push-circular ( elt circular -- )
|
||||
[ set-first ] [ 1 swap change-circular-start ] bi ;
|
||||
[ set-first ] [ rotate-circular ] bi ;
|
||||
|
||||
: <circular-string> ( n -- circular )
|
||||
0 <string> <circular> ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors
|
||||
namespaces make fry sequences ;
|
||||
namespaces math make fry sequences ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
id
|
||||
{ id integer }
|
||||
number
|
||||
{ instructions vector }
|
||||
{ successors vector }
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
|
|||
[ ##return? ]
|
||||
[ ##callback-return? ]
|
||||
[ ##jump? ]
|
||||
[ ##fixnum-add-tail? ]
|
||||
[ ##fixnum-sub-tail? ]
|
||||
[ ##fixnum-mul-tail? ]
|
||||
[ ##call? ]
|
||||
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces sequences math math.order kernel assocs
|
||||
accessors vectors fry heaps cpu.architecture combinators
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
accessors vectors fry heaps cpu.architecture sorting locals
|
||||
combinators compiler.cfg.registers
|
||||
compiler.cfg.linear-scan.live-intervals hints ;
|
||||
IN: compiler.cfg.linear-scan.allocation
|
||||
|
||||
! Mapping from register classes to sequences of machine registers
|
||||
|
|
@ -27,13 +27,61 @@ SYMBOL: active-intervals
|
|||
: delete-active ( live-interval -- )
|
||||
dup vreg>> active-intervals-for delq ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
active-intervals swap '[
|
||||
[
|
||||
[ end>> _ < ] partition
|
||||
[ [ deallocate-register ] each ] dip
|
||||
] assoc-map
|
||||
] change ;
|
||||
! Vector of inactive live intervals
|
||||
SYMBOL: inactive-intervals
|
||||
|
||||
: inactive-intervals-for ( vreg -- seq )
|
||||
reg-class>> inactive-intervals get at ;
|
||||
|
||||
: add-inactive ( live-interval -- )
|
||||
dup vreg>> inactive-intervals-for push ;
|
||||
|
||||
! Vector of handled live intervals
|
||||
SYMBOL: handled-intervals
|
||||
|
||||
: add-handled ( live-interval -- )
|
||||
handled-intervals get push ;
|
||||
|
||||
: finished? ( n live-interval -- ? ) end>> swap < ;
|
||||
|
||||
: finish ( n live-interval -- keep? )
|
||||
nip [ deallocate-register ] [ add-handled ] bi f ;
|
||||
|
||||
: activate ( n live-interval -- keep? )
|
||||
nip add-active f ;
|
||||
|
||||
: deactivate ( n live-interval -- keep? )
|
||||
nip add-inactive f ;
|
||||
|
||||
: don't-change ( n live-interval -- keep? ) 2drop t ;
|
||||
|
||||
! Moving intervals between active and inactive sets
|
||||
: process-intervals ( n symbol quots -- )
|
||||
! symbol stores an alist mapping register classes to vectors
|
||||
[ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
|
||||
|
||||
: covers? ( insn# live-interval -- ? )
|
||||
ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
|
||||
|
||||
: deactivate-intervals ( n -- )
|
||||
! Any active intervals which have ended are moved to handled
|
||||
! Any active intervals which cover the current position
|
||||
! are moved to inactive
|
||||
active-intervals {
|
||||
{ [ 2dup finished? ] [ finish ] }
|
||||
{ [ 2dup covers? not ] [ deactivate ] }
|
||||
[ don't-change ]
|
||||
} process-intervals ;
|
||||
|
||||
: activate-intervals ( n -- )
|
||||
! Any inactive intervals which have ended are moved to handled
|
||||
! Any inactive intervals which do not cover the current position
|
||||
! are moved to active
|
||||
inactive-intervals {
|
||||
{ [ 2dup finished? ] [ finish ] }
|
||||
{ [ 2dup covers? ] [ activate ] }
|
||||
[ don't-change ]
|
||||
} process-intervals ;
|
||||
|
||||
! Minheap of live intervals which still need a register allocation
|
||||
SYMBOL: unhandled-intervals
|
||||
|
|
@ -66,29 +114,64 @@ SYMBOL: progress
|
|||
|
||||
: coalesce ( live-interval -- )
|
||||
dup copy-from>> active-interval
|
||||
[ [ add-active ] [ delete-active ] bi* ]
|
||||
[ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
|
||||
[ reg>> >>reg drop ]
|
||||
2bi ;
|
||||
|
||||
! Splitting
|
||||
: find-use ( live-interval n quot -- i elt )
|
||||
[ uses>> ] 2dip curry find ; inline
|
||||
: split-range ( live-range n -- before after )
|
||||
[ [ from>> ] dip <live-range> ]
|
||||
[ 1 + swap to>> <live-range> ]
|
||||
2bi ;
|
||||
|
||||
: split-before ( live-interval i -- before )
|
||||
[ clone dup uses>> ] dip
|
||||
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
|
||||
: split-last-range? ( last n -- ? )
|
||||
swap to>> <= ;
|
||||
|
||||
: split-after ( live-interval i -- after )
|
||||
[ clone dup uses>> ] dip
|
||||
[ tail >>uses ] [ swap nth >>start ] 2bi
|
||||
f >>reg f >>copy-from ;
|
||||
: split-last-range ( before after last n -- before' after' )
|
||||
split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
|
||||
|
||||
: split-interval ( live-interval n -- before after )
|
||||
[ drop ] [ [ > ] find-use drop ] 2bi
|
||||
[ split-before ] [ split-after ] 2bi ;
|
||||
: split-ranges ( live-ranges n -- before after )
|
||||
[ '[ from>> _ <= ] partition ]
|
||||
[
|
||||
pick empty? [ drop ] [
|
||||
[ over last ] dip 2dup split-last-range?
|
||||
[ split-last-range ] [ 2drop ] if
|
||||
] if
|
||||
] bi ;
|
||||
|
||||
: split-uses ( uses n -- before after )
|
||||
'[ _ <= ] partition ;
|
||||
|
||||
: record-split ( live-interval before after -- )
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ;
|
||||
[ >>split-before ] [ >>split-after ] bi* drop ; inline
|
||||
|
||||
: check-split ( live-interval -- )
|
||||
[ end>> ] [ start>> ] bi - 0 =
|
||||
[ "BUG: splitting atomic interval" throw ] when ; inline
|
||||
|
||||
: split-before ( before -- before' )
|
||||
[ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
|
||||
[ compute-start/end ]
|
||||
[ ]
|
||||
tri ; inline
|
||||
|
||||
: split-after ( after -- after' )
|
||||
[ [ ranges>> first ] [ uses>> first ] bi >>from drop ]
|
||||
[ compute-start/end ]
|
||||
[ ]
|
||||
tri ; inline
|
||||
|
||||
:: split-interval ( live-interval n -- before after )
|
||||
live-interval check-split
|
||||
live-interval clone :> before
|
||||
live-interval clone f >>copy-from f >>reg :> after
|
||||
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
|
||||
live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
|
||||
live-interval before after record-split
|
||||
before split-before
|
||||
after split-after ;
|
||||
|
||||
HINTS: split-interval live-interval object ;
|
||||
|
||||
! Spilling
|
||||
SYMBOL: spill-counts
|
||||
|
|
@ -96,6 +179,9 @@ SYMBOL: spill-counts
|
|||
: next-spill-location ( reg-class -- n )
|
||||
spill-counts get [ dup 1+ ] change-at ;
|
||||
|
||||
: find-use ( live-interval n quot -- i elt )
|
||||
[ uses>> ] 2dip curry find ; inline
|
||||
|
||||
: interval-to-spill ( active-intervals current -- live-interval )
|
||||
#! We spill the interval with the most distant use location.
|
||||
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
|
||||
|
|
@ -108,8 +194,7 @@ SYMBOL: spill-counts
|
|||
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
|
||||
|
||||
: split-and-spill ( new existing -- before after )
|
||||
dup rot start>> split-interval
|
||||
[ record-split ] [ assign-spill ] 2bi ;
|
||||
swap start>> split-interval assign-spill ;
|
||||
|
||||
: reuse-register ( new existing -- )
|
||||
reg>> >>reg add-active ;
|
||||
|
|
@ -121,7 +206,7 @@ SYMBOL: spill-counts
|
|||
#! of the existing interval again.
|
||||
[ reuse-register ]
|
||||
[ nip delete-active ]
|
||||
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
|
||||
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
|
||||
|
||||
: spill-new ( new existing -- )
|
||||
#! Our new interval will be used after the active interval
|
||||
|
|
@ -141,37 +226,101 @@ SYMBOL: spill-counts
|
|||
: assign-free-register ( new registers -- )
|
||||
pop >>reg add-active ;
|
||||
|
||||
: assign-register ( new -- )
|
||||
dup coalesce? [
|
||||
coalesce
|
||||
: relevant-ranges ( new inactive -- new' inactive' )
|
||||
! Slice off all ranges of 'inactive' that precede the start of 'new'
|
||||
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
|
||||
|
||||
: intersect-live-range ( range1 range2 -- n/f )
|
||||
2dup [ from>> ] bi@ > [ swap ] when
|
||||
2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
|
||||
|
||||
: intersect-live-ranges ( ranges1 ranges2 -- n )
|
||||
{
|
||||
{ [ over empty? ] [ 2drop 1/0. ] }
|
||||
{ [ dup empty? ] [ 2drop 1/0. ] }
|
||||
[
|
||||
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
|
||||
drop
|
||||
2dup [ first from>> ] bi@ <
|
||||
[ [ rest-slice ] dip ] [ rest-slice ] if
|
||||
intersect-live-ranges
|
||||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: intersect-inactive ( new inactive -- n )
|
||||
relevant-ranges intersect-live-ranges ;
|
||||
|
||||
: intersecting-inactive ( new -- live-intervals )
|
||||
dup vreg>> inactive-intervals-for
|
||||
[ tuck intersect-inactive ] with { } map>assoc ;
|
||||
|
||||
: fits-in-hole ( new pair -- )
|
||||
first reuse-register ;
|
||||
|
||||
: split-before-use ( new pair -- before after )
|
||||
! Find optimal split position
|
||||
! Insert move instruction
|
||||
second split-interval ;
|
||||
|
||||
: assign-inactive-register ( new live-intervals -- )
|
||||
! If there is an interval which is inactive for the entire lifetime
|
||||
! if the new interval, reuse its vreg. Otherwise, split new so that
|
||||
! the first half fits.
|
||||
sort-values last
|
||||
2dup [ end>> ] [ second ] bi* < [
|
||||
fits-in-hole
|
||||
] [
|
||||
dup vreg>> free-registers-for
|
||||
[ assign-blocked-register ]
|
||||
[ assign-free-register ]
|
||||
[ split-before-use ] keep
|
||||
'[ _ fits-in-hole ] [ add-unhandled ] bi*
|
||||
] if ;
|
||||
|
||||
: assign-register ( new -- )
|
||||
dup coalesce? [ coalesce ] [
|
||||
dup vreg>> free-registers-for [
|
||||
dup intersecting-inactive
|
||||
[ assign-blocked-register ]
|
||||
[ assign-inactive-register ]
|
||||
if-empty
|
||||
] [ assign-free-register ]
|
||||
if-empty
|
||||
] if ;
|
||||
|
||||
! Main loop
|
||||
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
|
||||
CONSTANT: reg-classes { int-regs double-float-regs }
|
||||
|
||||
: reg-class-assoc ( quot -- assoc )
|
||||
[ reg-classes ] dip { } map>assoc ; inline
|
||||
|
||||
: init-allocator ( registers -- )
|
||||
<min-heap> unhandled-intervals set
|
||||
[ reverse >vector ] assoc-map free-registers set
|
||||
reg-classes [ 0 ] { } map>assoc spill-counts set
|
||||
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
|
||||
[ 0 ] reg-class-assoc spill-counts set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ V{ } clone ] reg-class-assoc active-intervals set
|
||||
[ V{ } clone ] reg-class-assoc inactive-intervals set
|
||||
V{ } clone handled-intervals set
|
||||
-1 progress set ;
|
||||
|
||||
: handle-interval ( live-interval -- )
|
||||
[ start>> progress set ]
|
||||
[ start>> expire-old-intervals ]
|
||||
[ assign-register ]
|
||||
tri ;
|
||||
[
|
||||
start>>
|
||||
[ progress set ]
|
||||
[ deactivate-intervals ]
|
||||
[ activate-intervals ] tri
|
||||
] [ assign-register ] bi ;
|
||||
|
||||
: (allocate-registers) ( -- )
|
||||
unhandled-intervals get [ handle-interval ] slurp-heap ;
|
||||
|
||||
: finish-allocation ( -- )
|
||||
! Sanity check: all live intervals should've been processed
|
||||
active-intervals inactive-intervals
|
||||
[ get values [ handled-intervals get push-all ] each ] bi@ ;
|
||||
|
||||
: allocate-registers ( live-intervals machine-registers -- live-intervals )
|
||||
#! This modifies the input live-intervals.
|
||||
init-allocator
|
||||
dup init-unhandled
|
||||
(allocate-registers) ;
|
||||
init-unhandled
|
||||
(allocate-registers)
|
||||
finish-allocation
|
||||
handled-intervals get ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math assocs namespaces sequences heaps
|
||||
fry make combinators
|
||||
fry make combinators sets
|
||||
cpu.architecture
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
IN: compiler.cfg.linear-scan.assignment
|
||||
|
||||
|
|
@ -25,35 +26,49 @@ TUPLE: active-intervals seq ;
|
|||
SYMBOL: unhandled-intervals
|
||||
|
||||
: add-unhandled ( live-interval -- )
|
||||
dup split-before>> [
|
||||
[ split-before>> ] [ split-after>> ] bi
|
||||
[ add-unhandled ] bi@
|
||||
] [
|
||||
dup start>> unhandled-intervals get heap-push
|
||||
] if ;
|
||||
dup start>> unhandled-intervals get heap-push ;
|
||||
|
||||
: init-unhandled ( live-intervals -- )
|
||||
[ add-unhandled ] each ;
|
||||
|
||||
! Mapping spill slots to vregs
|
||||
SYMBOL: spill-slots
|
||||
|
||||
: spill-slots-for ( vreg -- assoc )
|
||||
reg-class>> spill-slots get at ;
|
||||
|
||||
: record-spill ( live-interval -- )
|
||||
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
|
||||
2dup key? [ "BUG: Already spilled" throw ] [ set-at ] if ;
|
||||
|
||||
: insert-spill ( live-interval -- )
|
||||
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
|
||||
dup [ _spill ] [ 3drop ] if ;
|
||||
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
|
||||
|
||||
: handle-spill ( live-interval -- )
|
||||
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
active-intervals get
|
||||
[ swap '[ end>> _ = ] partition ] change-seq drop
|
||||
[ insert-spill ] each ;
|
||||
[ handle-spill ] each ;
|
||||
|
||||
: record-reload ( live-interval -- )
|
||||
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
|
||||
2dup key? [ delete-at ] [ "BUG: Already reloaded" throw ] if ;
|
||||
|
||||
: insert-reload ( live-interval -- )
|
||||
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
|
||||
dup [ _reload ] [ 3drop ] if ;
|
||||
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
|
||||
|
||||
: handle-reload ( live-interval -- )
|
||||
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
|
||||
|
||||
: activate-new-intervals ( n -- )
|
||||
#! Any live intervals which start on the current instruction
|
||||
#! are added to the active set.
|
||||
unhandled-intervals get dup heap-empty? [ 2drop ] [
|
||||
2dup heap-peek drop start>> = [
|
||||
heap-pop drop [ add-active ] [ insert-reload ] bi
|
||||
heap-pop drop
|
||||
[ add-active ] [ handle-reload ] bi
|
||||
activate-new-intervals
|
||||
] [ 2drop ] if
|
||||
] if ;
|
||||
|
|
@ -76,8 +91,7 @@ M: insn assign-before drop ;
|
|||
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
|
||||
|
||||
: compute-live-spill-slots ( -- spill-slots )
|
||||
unhandled-intervals get
|
||||
heap-values [ reload-from>> ] filter
|
||||
spill-slots get values [ values ] map concat
|
||||
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
|
||||
|
||||
M: ##gc assign-after
|
||||
|
|
@ -93,6 +107,7 @@ M: insn assign-after drop ;
|
|||
: init-assignment ( live-intervals -- )
|
||||
<active-intervals> active-intervals set
|
||||
<min-heap> unhandled-intervals set
|
||||
[ H{ } clone ] reg-class-assoc spill-slots set
|
||||
init-unhandled ;
|
||||
|
||||
: assign-registers-in-block ( bb -- )
|
||||
|
|
|
|||
|
|
@ -12,6 +12,60 @@ compiler.cfg.linear-scan.live-intervals
|
|||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.debugger ;
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
|
||||
{ T{ live-range f 16 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 15 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 16 } }
|
||||
{ T{ live-range f 17 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 16 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } }
|
||||
{ T{ live-range f 15 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 12 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 1 10 } T{ live-range f 15 17 } }
|
||||
{ T{ live-range f 18 20 } }
|
||||
] [
|
||||
{
|
||||
T{ live-range f 1 10 }
|
||||
T{ live-range f 15 20 }
|
||||
} 17 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ }
|
||||
{ T{ live-range f 1 10 } }
|
||||
] [
|
||||
{ T{ live-range f 1 10 } } 0 split-ranges
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ T{ live-range f 0 0 } }
|
||||
{ T{ live-range f 1 5 } }
|
||||
] [
|
||||
{ T{ live-range f 0 5 } } 0 split-ranges
|
||||
] unit-test
|
||||
|
||||
[ 7 ] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
|
|
@ -44,23 +98,26 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ 0 1 } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 5 }
|
||||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 5 }
|
||||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
{ ranges V{ T{ live-range f 5 5 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 2 split-interval
|
||||
] unit-test
|
||||
|
||||
|
|
@ -70,12 +127,14 @@ compiler.cfg.linear-scan.debugger ;
|
|||
{ start 0 }
|
||||
{ end 0 }
|
||||
{ uses V{ 0 } }
|
||||
{ ranges V{ T{ live-range f 0 0 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 1 }
|
||||
{ end 5 }
|
||||
{ uses V{ 1 5 } }
|
||||
{ ranges V{ T{ live-range f 1 5 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
|
|
@ -83,6 +142,7 @@ compiler.cfg.linear-scan.debugger ;
|
|||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 0 split-interval
|
||||
] unit-test
|
||||
|
||||
|
|
@ -173,7 +233,13 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -181,8 +247,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 10 }
|
||||
{ uses V{ 0 10 } }
|
||||
{ ranges V{ T{ live-range f 0 10 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 11 }
|
||||
{ end 20 }
|
||||
{ uses V{ 11 20 } }
|
||||
{ ranges V{ T{ live-range f 11 20 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -190,8 +268,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 60 }
|
||||
{ uses V{ 30 60 } }
|
||||
{ ranges V{ T{ live-range f 30 60 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -199,8 +289,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 200 }
|
||||
{ uses V{ 30 200 } }
|
||||
{ ranges V{ T{ live-range f 30 200 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -208,8 +310,20 @@ compiler.cfg.linear-scan.debugger ;
|
|||
|
||||
[
|
||||
{
|
||||
T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
|
||||
T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
|
||||
{ start 0 }
|
||||
{ end 100 }
|
||||
{ uses V{ 0 100 } }
|
||||
{ ranges V{ T{ live-range f 0 100 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
|
||||
{ start 30 }
|
||||
{ end 100 }
|
||||
{ uses V{ 30 100 } }
|
||||
{ ranges V{ T{ live-range f 30 100 } } }
|
||||
}
|
||||
}
|
||||
H{ { int-regs { "A" } } }
|
||||
check-linear-scan
|
||||
|
|
@ -272,31 +386,10 @@ USING: math.private compiler.cfg.debugger ;
|
|||
test-cfg first optimize-cfg linear-scan drop
|
||||
] unit-test
|
||||
|
||||
[ 0 1 ] [
|
||||
{
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 0 }
|
||||
{ end 5 }
|
||||
{ uses V{ 0 1 5 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
|
||||
{ start 3 }
|
||||
{ end 4 }
|
||||
{ uses V{ 3 4 } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 2 }
|
||||
{ end 6 }
|
||||
{ uses V{ 2 4 6 } }
|
||||
}
|
||||
} [ clone ] map
|
||||
H{ { int-regs { "A" "B" } } }
|
||||
allocate-registers
|
||||
first split-before>> [ start>> ] [ end>> ] bi
|
||||
] unit-test
|
||||
: fake-live-ranges ( seq -- seq' )
|
||||
[
|
||||
clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
|
||||
] map ;
|
||||
|
||||
! Coalescing interacted badly with splitting
|
||||
[ ] [
|
||||
|
|
@ -345,7 +438,7 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 10 }
|
||||
{ uses V{ 9 10 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
|
@ -1100,7 +1193,7 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 109 }
|
||||
{ uses V{ 103 109 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 4 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
|
@ -1193,7 +1286,92 @@ USING: math.private compiler.cfg.debugger ;
|
|||
{ end 92 }
|
||||
{ uses V{ 42 45 78 80 92 } }
|
||||
}
|
||||
}
|
||||
} fake-live-ranges
|
||||
{ { int-regs { 0 1 2 3 } } }
|
||||
allocate-registers drop
|
||||
] unit-test
|
||||
|
||||
! Spill slot liveness was computed incorrectly, leading to a FEP
|
||||
! early in bootstrap on x86-32
|
||||
[ t ] [
|
||||
T{ basic-block
|
||||
{ instructions
|
||||
V{
|
||||
T{ ##gc f V int-regs 6 V int-regs 7 }
|
||||
T{ ##peek f V int-regs 0 D 0 }
|
||||
T{ ##peek f V int-regs 1 D 1 }
|
||||
T{ ##peek f V int-regs 2 D 2 }
|
||||
T{ ##peek f V int-regs 3 D 3 }
|
||||
T{ ##peek f V int-regs 4 D 4 }
|
||||
T{ ##peek f V int-regs 5 D 5 }
|
||||
T{ ##replace f V int-regs 0 D 1 }
|
||||
T{ ##replace f V int-regs 1 D 2 }
|
||||
T{ ##replace f V int-regs 2 D 3 }
|
||||
T{ ##replace f V int-regs 3 D 4 }
|
||||
T{ ##replace f V int-regs 4 D 5 }
|
||||
T{ ##replace f V int-regs 5 D 0 }
|
||||
}
|
||||
}
|
||||
} dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
|
||||
instructions>> first live-spill-slots>> empty?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 20 30 }
|
||||
intersect-live-range
|
||||
] unit-test
|
||||
|
||||
[ 10 ] [
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 10 30 }
|
||||
intersect-live-range
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 5 30 }
|
||||
intersect-live-range
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
T{ live-range f 5 30 }
|
||||
T{ live-range f 0 10 }
|
||||
intersect-live-range
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
T{ live-range f 5 10 }
|
||||
T{ live-range f 0 15 }
|
||||
intersect-live-range
|
||||
] unit-test
|
||||
|
||||
[ 50 ] [
|
||||
{
|
||||
T{ live-range f 0 10 }
|
||||
T{ live-range f 20 30 }
|
||||
T{ live-range f 40 50 }
|
||||
}
|
||||
{
|
||||
T{ live-range f 11 15 }
|
||||
T{ live-range f 31 35 }
|
||||
T{ live-range f 50 55 }
|
||||
}
|
||||
intersect-live-ranges
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
T{ live-interval
|
||||
{ start 0 }
|
||||
{ end 10 }
|
||||
{ uses { 0 10 } }
|
||||
{ ranges V{ T{ live-range f 0 10 } } }
|
||||
}
|
||||
T{ live-interval
|
||||
{ start 5 }
|
||||
{ end 10 }
|
||||
{ uses { 5 10 } }
|
||||
{ ranges V{ T{ live-range f 5 10 } } }
|
||||
}
|
||||
intersect-inactive
|
||||
] unit-test
|
||||
|
|
@ -25,13 +25,15 @@ IN: compiler.cfg.linear-scan
|
|||
! by Omri Traub, Glenn Holloway, Michael D. Smith
|
||||
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
|
||||
|
||||
: (linear-scan) ( rpo -- )
|
||||
dup number-instructions
|
||||
dup compute-live-intervals
|
||||
machine-registers allocate-registers assign-registers ;
|
||||
: (linear-scan) ( rpo machine-registers -- )
|
||||
[
|
||||
dup number-instructions
|
||||
dup compute-live-intervals
|
||||
] dip
|
||||
allocate-registers assign-registers ;
|
||||
|
||||
: linear-scan ( cfg -- cfg' )
|
||||
[
|
||||
dup reverse-post-order (linear-scan)
|
||||
dup reverse-post-order machine-registers (linear-scan)
|
||||
spill-counts get >>spill-counts
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs accessors sequences math math.order fry
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
binary-search compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
|
||||
IN: compiler.cfg.linear-scan.live-intervals
|
||||
|
||||
|
|
@ -109,6 +109,7 @@ M: ##copy-float compute-live-intervals*
|
|||
|
||||
: compute-start/end ( live-interval -- )
|
||||
dup ranges>> [ first from>> ] [ last to>> ] bi
|
||||
2dup > [ "BUG: start > end" throw ] when
|
||||
[ >>start ] [ >>end ] bi* drop ;
|
||||
|
||||
: finish-live-intervals ( live-intervals -- )
|
||||
|
|
|
|||
|
|
@ -11,9 +11,17 @@ compiler.cfg.dce
|
|||
compiler.cfg.write-barrier
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.phi-elimination ;
|
||||
compiler.cfg.phi-elimination
|
||||
compiler.cfg.checker ;
|
||||
IN: compiler.cfg.optimizer
|
||||
|
||||
SYMBOL: check-optimizer?
|
||||
|
||||
: ?check ( cfg -- cfg' )
|
||||
check-optimizer? get [
|
||||
dup check-cfg
|
||||
] when ;
|
||||
|
||||
: optimize-cfg ( cfg -- cfg' )
|
||||
[
|
||||
compute-predecessors
|
||||
|
|
@ -27,4 +35,5 @@ IN: compiler.cfg.optimizer
|
|||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
eliminate-phis
|
||||
?check
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel sequences make compiler.cfg.instructions
|
||||
compiler.cfg.rpo cpu.architecture ;
|
||||
USING: accessors kernel sequences make compiler.cfg.instructions
|
||||
compiler.cfg.local cpu.architecture ;
|
||||
IN: compiler.cfg.two-operand
|
||||
|
||||
! On x86, instructions take the form x = x op y
|
||||
! Our SSA IR is x = y op z
|
||||
|
||||
! We don't bother with ##add, ##add-imm or ##sub-imm since x86
|
||||
! has a LEA instruction which is effectively a three-operand
|
||||
! addition
|
||||
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
|
||||
! since x86 has LEA and IMUL instructions which are effectively
|
||||
! three-operand addition and multiplication, respectively.
|
||||
|
||||
: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
|
||||
|
||||
|
|
@ -34,7 +34,6 @@ M: ##not convert-two-operand*
|
|||
|
||||
M: ##sub convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##mul convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##and convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##and-imm convert-two-operand* convert-two-operand/integer ;
|
||||
M: ##or convert-two-operand* convert-two-operand/integer ;
|
||||
|
|
@ -54,9 +53,7 @@ M: insn convert-two-operand* , ;
|
|||
|
||||
: convert-two-operand ( cfg -- cfg' )
|
||||
two-operand? [
|
||||
dup [
|
||||
[
|
||||
[ [ convert-two-operand* ] each ] V{ } make
|
||||
] change-instructions drop
|
||||
] each-basic-block
|
||||
[ drop ]
|
||||
[ [ [ convert-two-operand* ] each ] V{ } make ]
|
||||
local-optimization
|
||||
] when ;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ continuations.private fry cpu.architecture
|
|||
source-files.errors
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.constants
|
||||
compiler.cfg
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.stack-frame
|
||||
|
|
@ -94,7 +95,9 @@ M: _dispatch generate-insn
|
|||
[ src>> register ] [ temp>> register ] bi %dispatch ;
|
||||
|
||||
M: _dispatch-label generate-insn
|
||||
label>> lookup-label %dispatch-label ;
|
||||
label>> lookup-label
|
||||
cell 0 <repetition> %
|
||||
rc-absolute-cell label-fixup ;
|
||||
|
||||
: >slot< ( insn -- dst obj slot tag )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -193,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist )
|
|||
] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
] with-scope ;
|
||||
] with-scope
|
||||
"trace-compilation" get [ "--- compile done" print flush ] when ;
|
||||
|
||||
: with-optimizer ( quot -- )
|
||||
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||
|
|
|
|||
|
|
@ -55,7 +55,6 @@ HOOK: %jump-label cpu ( label -- )
|
|||
HOOK: %return cpu ( -- )
|
||||
|
||||
HOOK: %dispatch cpu ( src temp -- )
|
||||
HOOK: %dispatch-label cpu ( label -- )
|
||||
|
||||
HOOK: %slot cpu ( dst obj slot tag temp -- )
|
||||
HOOK: %slot-imm cpu ( dst obj slot tag -- )
|
||||
|
|
|
|||
|
|
@ -3,10 +3,11 @@
|
|||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.accessors alien.c-types literals cpu.architecture
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.units ;
|
||||
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
|
||||
compiler.units ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: cpu.ppc
|
||||
|
||||
|
|
@ -461,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
|
|||
src card# deck-bits SRWI
|
||||
table scratch-reg card# STBX ;
|
||||
|
||||
M: ppc %gc
|
||||
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
|
||||
"end" define-label
|
||||
12 load-zone-ptr
|
||||
11 12 cell LWZ ! nursery.here -> r11
|
||||
12 12 3 cells LWZ ! nursery.end -> r12
|
||||
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||
11 0 12 CMP ! is here >= end?
|
||||
temp2 load-zone-ptr
|
||||
temp1 temp2 cell LWZ
|
||||
temp2 temp2 3 cells LWZ
|
||||
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||
temp1 0 temp2 CMP ! is here >= end?
|
||||
"end" get BLE
|
||||
%prepare-alien-invoke
|
||||
"minor_gc" f %alien-invoke
|
||||
0 3 LI
|
||||
0 4 LI
|
||||
"inline_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
|
||||
M: ppc %prologue ( n -- )
|
||||
|
|
|
|||
|
|
@ -64,3 +64,11 @@ IN: cpu.x86.assembler.tests
|
|||
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
|
||||
|
||||
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
|
||||
|
||||
[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
|
||||
[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
|
||||
[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
|
||||
[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test
|
||||
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
|
||||
|
||||
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators kernel.private math
|
||||
namespaces make sequences words system layouts math.order accessors
|
||||
cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
|
@ -402,20 +402,26 @@ M: operand TEST OCT: 204 2-operand ;
|
|||
: SHR ( dst n -- ) BIN: 101 (SHIFT) ;
|
||||
: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
|
||||
|
||||
GENERIC: IMUL2 ( dst src -- )
|
||||
M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
|
||||
M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
|
||||
: IMUL2 ( dst src -- )
|
||||
OCT: 257 extended-opcode (2-operand) ;
|
||||
|
||||
: IMUL3 ( dst src imm -- )
|
||||
dup fits-in-byte? [
|
||||
[ swap HEX: 6a 2-operand ] dip 1,
|
||||
] [
|
||||
[ swap HEX: 68 2-operand ] dip 4,
|
||||
] if ;
|
||||
|
||||
: MOVSX ( dst src -- )
|
||||
dup register-32? OCT: 143 OCT: 276 extended-opcode ?
|
||||
over register-16? [ BIN: 1 opcode-or ] when
|
||||
swapd
|
||||
swap
|
||||
over register-32? OCT: 143 OCT: 276 extended-opcode ?
|
||||
pick register-16? [ BIN: 1 opcode-or ] when
|
||||
(2-operand) ;
|
||||
|
||||
: MOVZX ( dst src -- )
|
||||
swap
|
||||
OCT: 266 extended-opcode
|
||||
over register-16? [ BIN: 1 opcode-or ] when
|
||||
swapd
|
||||
pick register-16? [ BIN: 1 opcode-or ] when
|
||||
(2-operand) ;
|
||||
|
||||
! Conditional move
|
||||
|
|
|
|||
|
|
@ -91,9 +91,6 @@ M: x86 %return ( -- ) 0 RET ;
|
|||
: align-code ( n -- )
|
||||
0 <repetition> % ;
|
||||
|
||||
M: x86 %dispatch-label ( label -- )
|
||||
0 cell, rc-absolute-cell label-fixup ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- op )
|
||||
temp slot obj [+] LEA
|
||||
temp tag neg [+] ; inline
|
||||
|
|
@ -111,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
|
|||
M: x86 %sub nip SUB ;
|
||||
M: x86 %sub-imm neg [+] LEA ;
|
||||
M: x86 %mul nip swap IMUL2 ;
|
||||
M: x86 %mul-imm nip IMUL2 ;
|
||||
M: x86 %mul-imm IMUL3 ;
|
||||
M: x86 %and nip AND ;
|
||||
M: x86 %and-imm nip AND ;
|
||||
M: x86 %or nip OR ;
|
||||
|
|
|
|||
|
|
@ -77,6 +77,9 @@ IN: formatting.tests
|
|||
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
|
||||
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
|
||||
|
||||
[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
|
||||
[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
|
||||
|
||||
|
||||
[ "%H:%M:%S" strftime ] must-infer
|
||||
|
||||
|
|
@ -95,3 +98,4 @@ IN: formatting.tests
|
|||
[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
|
||||
[ t ] [ "PM" testtime "%p" strftime = ] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: assocs continuations fry help help.lint.checks
|
||||
help.topics io kernel namespaces parser sequences
|
||||
source-files.errors vocabs.hierarchy vocabs words classes
|
||||
locals tools.errors ;
|
||||
locals tools.errors listener ;
|
||||
FROM: help.lint.checks => all-vocabs ;
|
||||
IN: help.lint
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
Chris Double
|
||||
Peter Burns
|
||||
Philipp Winkler
|
||||
|
|
|
|||
|
|
@ -19,6 +19,8 @@ IN: json.reader.tests
|
|||
{ 10.25 } [ "1025e-2" json> ] unit-test
|
||||
{ 0.125 } [ "0.125" json> ] unit-test
|
||||
{ -0.125 } [ "-0.125" json> ] unit-test
|
||||
{ -0.00125 } [ "-0.125e-2" json> ] unit-test
|
||||
{ -012.5 } [ "-0.125e+2" json> ] unit-test
|
||||
|
||||
! not widely supported by javascript, but allowed in the grammar, and a nice
|
||||
! feature to get
|
||||
|
|
@ -31,6 +33,7 @@ IN: json.reader.tests
|
|||
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
|
||||
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
|
||||
|
||||
{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
|
||||
{ { } } [ "[]" json> ] unit-test
|
||||
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
|
||||
{ H{ } } [ "{}" json> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,61 +1,103 @@
|
|||
! Copyright (C) 2008 Peter Burns.
|
||||
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg peg.ebnf math.parser math.parser.private strings math
|
||||
math.functions sequences arrays vectors hashtables assocs
|
||||
prettyprint json ;
|
||||
USING: arrays assocs combinators io io.streams.string json
|
||||
kernel math math.parser math.parser.private prettyprint
|
||||
sequences strings vectors ;
|
||||
IN: json.reader
|
||||
|
||||
<PRIVATE
|
||||
: value ( char -- num char )
|
||||
1string " \t\r\n,:}]" read-until
|
||||
[
|
||||
append
|
||||
[ string>float ]
|
||||
[ [ "eE." index ] any? [ >integer ] unless ] bi
|
||||
] dip ;
|
||||
|
||||
: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
|
||||
DEFER: j-string
|
||||
|
||||
: convert-string ( str -- str )
|
||||
read1
|
||||
{
|
||||
{ CHAR: b [ 8 ] }
|
||||
{ CHAR: f [ 12 ] }
|
||||
{ CHAR: n [ CHAR: \n ] }
|
||||
{ CHAR: r [ CHAR: \r ] }
|
||||
{ CHAR: t [ CHAR: \t ] }
|
||||
{ CHAR: u [ 4 read hex> ] }
|
||||
[ ]
|
||||
} case
|
||||
dup
|
||||
[ 1string append j-string append ]
|
||||
[ drop ] if ;
|
||||
|
||||
: j-string ( -- str )
|
||||
"\\\"" read-until CHAR: \" =
|
||||
[ convert-string ] unless ;
|
||||
|
||||
: second-last ( seq -- second-last )
|
||||
[ length 2 - ] keep nth ; inline
|
||||
|
||||
! Grammar for JSON from RFC 4627
|
||||
EBNF: (json>)
|
||||
: third-last ( seq -- third-last )
|
||||
[ length 3 - ] keep nth ; inline
|
||||
|
||||
: last2 ( seq -- second-last last )
|
||||
[ second-last ] [ last ] bi ; inline
|
||||
|
||||
ws = (" " | "\r" | "\t" | "\n")*
|
||||
: last3 ( seq -- third-last second-last last )
|
||||
[ third-last ] [ last2 ] bi ; inline
|
||||
|
||||
true = "true" => [[ t ]]
|
||||
false = "false" => [[ f ]]
|
||||
null = "null" => [[ json-null ]]
|
||||
: v-over-push ( vec -- vec' )
|
||||
dup length 2 >=
|
||||
[
|
||||
dup
|
||||
[ pop ]
|
||||
[ last ] bi push
|
||||
] when ;
|
||||
|
||||
hex = [0-9a-fA-F]
|
||||
char = '\\"' [[ CHAR: " ]]
|
||||
| "\\\\" [[ CHAR: \ ]]
|
||||
| "\\/" [[ CHAR: / ]]
|
||||
| "\\b" [[ 8 ]]
|
||||
| "\\f" [[ 12 ]]
|
||||
| "\\n" [[ CHAR: \n ]]
|
||||
| "\\r" [[ CHAR: \r ]]
|
||||
| "\\t" [[ CHAR: \t ]]
|
||||
| "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]]
|
||||
| [^"\]
|
||||
string = '"' char*:cs '"' => [[ cs >string ]]
|
||||
: v-pick-push ( vec -- vec' )
|
||||
dup length 3 >=
|
||||
[
|
||||
dup
|
||||
[ pop ]
|
||||
[ second-last ] bi push
|
||||
] when ;
|
||||
|
||||
sign = ("-" | "+")? => [[ "-" = "-" "" ? ]]
|
||||
digits = [0-9]+ => [[ >string ]]
|
||||
decimal = "." digits => [[ concat ]]
|
||||
exp = ("e" | "E") sign digits => [[ concat ]]
|
||||
number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
|
||||
: (close-array) ( accum -- accum' )
|
||||
dup last vector? [ v-over-push ] unless
|
||||
dup pop >array over push ;
|
||||
|
||||
elements = value ("," value)* => [[ grammar-list>vector ]]
|
||||
array = "[" elements?:arr "]" => [[ arr >array ]]
|
||||
|
||||
pair = ws string:key ws ":" value:val => [[ { key val } ]]
|
||||
members = pair ("," pair)* => [[ grammar-list>vector ]]
|
||||
object = "{" members?:hash "}" => [[ hash >hashtable ]]
|
||||
|
||||
val = true
|
||||
| false
|
||||
| null
|
||||
| string
|
||||
| number
|
||||
| array
|
||||
| object
|
||||
|
||||
value = ws val:v ws => [[ v ]]
|
||||
|
||||
;EBNF
|
||||
: (close-hash) ( accum -- accum' )
|
||||
dup length 3 >= [ v-over-push ] when
|
||||
dup dup [ pop ] dip pop swap
|
||||
zip H{ } assoc-clone-like over push ;
|
||||
|
||||
: scan ( accum char -- accum )
|
||||
! 2dup . . ! Great for debug...
|
||||
[
|
||||
{
|
||||
{ CHAR: \" [ j-string over push ] }
|
||||
{ CHAR: [ [ V{ } clone over push ] }
|
||||
{ CHAR: , [ v-over-push ] }
|
||||
{ CHAR: ] [ (close-array) ] }
|
||||
{ CHAR: { [ 2 [ V{ } clone over push ] times ] }
|
||||
{ CHAR: : [ v-pick-push ] }
|
||||
{ CHAR: } [ (close-hash) ] }
|
||||
{ CHAR: \u000020 [ ] }
|
||||
{ CHAR: \t [ ] }
|
||||
{ CHAR: \r [ ] }
|
||||
{ CHAR: \n [ ] }
|
||||
{ CHAR: t [ 3 read drop t over push ] }
|
||||
{ CHAR: f [ 4 read drop f over push ] }
|
||||
{ CHAR: n [ 3 read drop json-null over push ] }
|
||||
[ value [ over push ] dip [ scan ] when* ]
|
||||
} case
|
||||
] when* ;
|
||||
|
||||
: (json-parser>) ( string -- object )
|
||||
[ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: json> ( string -- object ) (json>) ;
|
||||
|
||||
: json> ( string -- object )
|
||||
(json-parser>) ;
|
||||
|
|
@ -13,6 +13,10 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
|
|||
"Hiding all visible variables:"
|
||||
{ $subsection hide-all-vars } ;
|
||||
|
||||
HELP: only-use-vocabs
|
||||
{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
|
||||
{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
|
||||
|
||||
HELP: show-var
|
||||
{ $values { "var" "a variable name" } }
|
||||
{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
|
|||
namespaces parser lexer sequences strings io.styles
|
||||
vectors words generic system combinators continuations debugger
|
||||
definitions compiler.units accessors colors prettyprint fry
|
||||
sets vocabs.parser source-files.errors locals ;
|
||||
sets vocabs.parser source-files.errors locals vocabs vocabs.loader ;
|
||||
IN: listener
|
||||
|
||||
GENERIC: stream-read-quot ( stream -- quot/f )
|
||||
|
|
@ -124,6 +124,78 @@ t error-summary? set-global
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: interactive-vocabs
|
||||
|
||||
{
|
||||
"accessors"
|
||||
"arrays"
|
||||
"assocs"
|
||||
"combinators"
|
||||
"compiler"
|
||||
"compiler.errors"
|
||||
"compiler.units"
|
||||
"continuations"
|
||||
"debugger"
|
||||
"definitions"
|
||||
"editors"
|
||||
"help"
|
||||
"help.apropos"
|
||||
"help.lint"
|
||||
"help.vocabs"
|
||||
"inspector"
|
||||
"io"
|
||||
"io.files"
|
||||
"io.pathnames"
|
||||
"kernel"
|
||||
"listener"
|
||||
"math"
|
||||
"math.order"
|
||||
"memory"
|
||||
"namespaces"
|
||||
"parser"
|
||||
"prettyprint"
|
||||
"see"
|
||||
"sequences"
|
||||
"slicing"
|
||||
"sorting"
|
||||
"stack-checker"
|
||||
"strings"
|
||||
"syntax"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.disassembler"
|
||||
"tools.errors"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
"tools.test"
|
||||
"tools.threads"
|
||||
"tools.time"
|
||||
"vocabs"
|
||||
"vocabs.loader"
|
||||
"vocabs.refresh"
|
||||
"vocabs.hierarchy"
|
||||
"words"
|
||||
"scratchpad"
|
||||
} interactive-vocabs set-global
|
||||
|
||||
: only-use-vocabs ( vocabs -- )
|
||||
clear-manifest
|
||||
[ vocab ] filter
|
||||
[
|
||||
vocab
|
||||
[ find-vocab-root not ]
|
||||
[ source-loaded?>> +done+ eq? ] bi or
|
||||
] filter
|
||||
[ use-vocab ] each ;
|
||||
|
||||
: with-interactive-vocabs ( quot -- )
|
||||
[
|
||||
<manifest> manifest set
|
||||
"scratchpad" set-current-vocab
|
||||
interactive-vocabs get only-use-vocabs
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
: listener ( -- )
|
||||
[ [ { } (listener) ] with-interactive-vocabs ] with-return ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint prettyprint.config
|
|||
prettyprint.sections sequences tools.test vectors words
|
||||
effects splitting generic.standard prettyprint.private
|
||||
continuations generic compiler.units tools.continuations
|
||||
tools.continuations.private eval accessors make vocabs.parser see ;
|
||||
tools.continuations.private eval accessors make vocabs.parser see
|
||||
listener ;
|
||||
IN: prettyprint.tests
|
||||
|
||||
[ "4" ] [ 4 unparse ] unit-test
|
||||
|
|
|
|||
|
|
@ -277,8 +277,6 @@ IN: tools.deploy.shaker
|
|||
compiled-generic-crossref
|
||||
compiler-impl
|
||||
compiler.errors:compiler-errors
|
||||
! definition-observers
|
||||
interactive-vocabs
|
||||
lexer-factory
|
||||
print-use-hook
|
||||
root-cache
|
||||
|
|
|
|||
|
|
@ -112,68 +112,6 @@ SYMBOL: bootstrap-syntax
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
SYMBOL: interactive-vocabs
|
||||
|
||||
{
|
||||
"accessors"
|
||||
"arrays"
|
||||
"assocs"
|
||||
"combinators"
|
||||
"compiler"
|
||||
"compiler.errors"
|
||||
"compiler.units"
|
||||
"continuations"
|
||||
"debugger"
|
||||
"definitions"
|
||||
"editors"
|
||||
"help"
|
||||
"help.apropos"
|
||||
"help.lint"
|
||||
"help.vocabs"
|
||||
"inspector"
|
||||
"io"
|
||||
"io.files"
|
||||
"io.pathnames"
|
||||
"kernel"
|
||||
"listener"
|
||||
"math"
|
||||
"math.order"
|
||||
"memory"
|
||||
"namespaces"
|
||||
"parser"
|
||||
"prettyprint"
|
||||
"see"
|
||||
"sequences"
|
||||
"slicing"
|
||||
"sorting"
|
||||
"stack-checker"
|
||||
"strings"
|
||||
"syntax"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.disassembler"
|
||||
"tools.errors"
|
||||
"tools.memory"
|
||||
"tools.profiler"
|
||||
"tools.test"
|
||||
"tools.threads"
|
||||
"tools.time"
|
||||
"vocabs"
|
||||
"vocabs.loader"
|
||||
"vocabs.refresh"
|
||||
"vocabs.hierarchy"
|
||||
"words"
|
||||
"scratchpad"
|
||||
} interactive-vocabs set-global
|
||||
|
||||
: with-interactive-vocabs ( quot -- )
|
||||
[
|
||||
<manifest> manifest set
|
||||
"scratchpad" set-current-vocab
|
||||
interactive-vocabs get only-use-vocabs
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
SYMBOL: print-use-hook
|
||||
|
||||
print-use-hook [ [ ] ] initialize
|
||||
|
|
|
|||
|
|
@ -65,7 +65,6 @@ $nl
|
|||
"Words for working with the current manifest:"
|
||||
{ $subsection use-vocab }
|
||||
{ $subsection unuse-vocab }
|
||||
{ $subsection only-use-vocabs }
|
||||
{ $subsection add-qualified }
|
||||
{ $subsection add-words-from }
|
||||
{ $subsection add-words-excluding }
|
||||
|
|
@ -117,10 +116,6 @@ HELP: unuse-vocab
|
|||
{ $description "Removes a vocabulary from the current manifest." }
|
||||
{ $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ;
|
||||
|
||||
HELP: only-use-vocabs
|
||||
{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
|
||||
{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
|
||||
|
||||
HELP: add-qualified
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "prefix" string } }
|
||||
{ $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." }
|
||||
|
|
|
|||
|
|
@ -52,8 +52,6 @@ M: extra-words equal?
|
|||
|
||||
C: <extra-words> extra-words
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: clear-manifest ( -- )
|
||||
manifest get
|
||||
[ search-vocab-names>> clear-assoc ]
|
||||
|
|
@ -61,6 +59,8 @@ C: <extra-words> extra-words
|
|||
[ qualified-vocabs>> delete-all ]
|
||||
tri ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (add-qualified) ( qualified -- )
|
||||
manifest get qualified-vocabs>> push ;
|
||||
|
||||
|
|
@ -126,9 +126,6 @@ TUPLE: no-current-vocab ;
|
|||
2bi
|
||||
] [ drop ] if ;
|
||||
|
||||
: only-use-vocabs ( vocabs -- )
|
||||
clear-manifest [ vocab ] filter [ use-vocab ] each ;
|
||||
|
||||
TUPLE: qualified vocab prefix words ;
|
||||
|
||||
: <qualified> ( vocab prefix -- qualified )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2009 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.syntax help.markup brainfuck strings ;
|
||||
|
||||
IN: brainfuck
|
||||
|
||||
HELP: run-brainfuck
|
||||
{ $values { "code" string } }
|
||||
{ $description
|
||||
"A brainfuck program is a sequence of eight commands that are "
|
||||
"executed sequentially. An instruction pointer begins at the first "
|
||||
"command, and each command is executed until the program terminates "
|
||||
"when the instruction pointer moves beyond the last command.\n"
|
||||
"\n"
|
||||
"The eight language commands, each consisting of a single character, "
|
||||
"are the following:\n"
|
||||
{ $table
|
||||
{ "Character" "Meaning" }
|
||||
{ ">" "increment the data pointer (to point to the next cell to the right)." }
|
||||
{ "<" "decrement the data pointer (to point to the next cell to the left)." }
|
||||
{ "+" "increment (increase by one) the byte at the data pointer." }
|
||||
{ "-" "decrement (decrease by one) the byte at the data pointer." }
|
||||
{ "." "output the value of the byte at the data pointer." }
|
||||
{ "," "accept one byte of input, storing its value in the byte at the data pointer." }
|
||||
{ "[" "if the byte at the data pointer is zero, then instead of moving the instruction pointer forward to the next command, jump it forward to the command after the matching ] command*." }
|
||||
{ "]" "if the byte at the data pointer is nonzero, then instead of moving the instruction pointer forward to the next command, jump it back to the command after the matching [ command*." }
|
||||
}
|
||||
"\n"
|
||||
"Brainfuck programs can be translated into C using the following "
|
||||
"substitutions, assuming ptr is of type unsigned char* and has been "
|
||||
"initialized to point to an array of zeroed bytes:\n"
|
||||
{ $table
|
||||
{ "Character" "C equivalent" }
|
||||
{ ">" "++ptr;" }
|
||||
{ "<" "--ptr;" }
|
||||
{ "+" "++*ptr;" }
|
||||
{ "-" "--*ptr;" }
|
||||
{ "." "putchar(*ptr);" }
|
||||
{ "," "*ptr=getchar();" }
|
||||
{ "[" "while (*ptr) {" }
|
||||
{ "]" "}" }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: get-brainfuck
|
||||
{ $values { "code" string } { "result" string } }
|
||||
{ $description "Returns the output from a brainfuck program as a result string." }
|
||||
{ $see-also run-brainfuck } ;
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
! Copyright (C) 2009 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: brainfuck kernel io.streams.string math math.parser math.ranges
|
||||
multiline quotations sequences tools.test ;
|
||||
|
||||
|
||||
[ "+" run-brainfuck ] must-infer
|
||||
[ "+" get-brainfuck ] must-infer
|
||||
|
||||
! Hello World!
|
||||
|
||||
[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
|
||||
>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
|
||||
------.--------.>+.>. "> get-brainfuck ] unit-test
|
||||
|
||||
! Addition (single-digit)
|
||||
|
||||
[ "8" ] [ "35" [ ",>++++++[<-------->-],[<+>-]<."
|
||||
get-brainfuck ] with-string-reader ] unit-test
|
||||
|
||||
! Multiplication (single-digit)
|
||||
|
||||
[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
|
||||
<<[>[>+>+<<-]>>[<<+>>-]<<<-]
|
||||
>>>++++++[<++++++++>-],<.>. ">
|
||||
get-brainfuck ] with-string-reader ] unit-test
|
||||
|
||||
! Division (single-digit, integer)
|
||||
|
||||
[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
|
||||
<<[
|
||||
>[->+>+<<]
|
||||
>[-<<-
|
||||
[>]>>>[<[>>>-<<<[-]]>>]<<]
|
||||
>>>+
|
||||
<<[-<<+>>]
|
||||
<<<]
|
||||
>[-]>>>>[-<<<<<+>>>>>]
|
||||
<<<<++++++[-<++++++++>]<. ">
|
||||
get-brainfuck ] with-string-reader ] unit-test
|
||||
|
||||
! Uppercase
|
||||
|
||||
[ "A" ] [ "a\n" [ ",----------[----------------------.,----------]"
|
||||
get-brainfuck ] with-string-reader ] unit-test
|
||||
|
||||
! cat
|
||||
|
||||
[ "ABC" ] [ "ABC\0" [ ",[.,]" get-brainfuck ] with-string-reader ] unit-test
|
||||
|
||||
! Squares of numbers from 0 to 100
|
||||
|
||||
100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
|
||||
[ <" ++++[>+++++<-]>[<+++++>-]+<+[
|
||||
>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
|
||||
>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
|
||||
<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
|
||||
[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
|
||||
get-brainfuck ] unit-test
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
! Copyright (C) 2009 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors assocs fry io io.streams.string kernel macros math
|
||||
peg.ebnf prettyprint quotations sequences strings ;
|
||||
|
||||
IN: brainfuck
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: brainfuck pointer memory ;
|
||||
|
||||
: <brainfuck> ( -- brainfuck )
|
||||
0 H{ } clone brainfuck boa ;
|
||||
|
||||
: get-memory ( brainfuck -- brainfuck value )
|
||||
dup [ pointer>> ] [ memory>> ] bi at 0 or ;
|
||||
|
||||
: set-memory ( brainfuck value -- brainfuck )
|
||||
over [ pointer>> ] [ memory>> ] bi set-at ;
|
||||
|
||||
: (+) ( brainfuck n -- brainfuck )
|
||||
[ get-memory ] dip + 255 bitand set-memory ;
|
||||
|
||||
: (-) ( brainfuck n -- brainfuck )
|
||||
[ get-memory ] dip - 255 bitand set-memory ;
|
||||
|
||||
: (?) ( brainfuck -- brainfuck t/f )
|
||||
get-memory 0 = not ;
|
||||
|
||||
: (.) ( brainfuck -- brainfuck )
|
||||
get-memory 1string write ;
|
||||
|
||||
: (,) ( brainfuck -- brainfuck )
|
||||
read1 set-memory ;
|
||||
|
||||
: (>) ( brainfuck n -- brainfuck )
|
||||
[ dup pointer>> ] dip + >>pointer ;
|
||||
|
||||
: (<) ( brainfuck n -- brainfuck )
|
||||
[ dup pointer>> ] dip - >>pointer ;
|
||||
|
||||
: (#) ( brainfuck -- brainfuck )
|
||||
dup
|
||||
[ "ptr=" write pointer>> pprint ]
|
||||
[ ",mem=" write memory>> pprint nl ] bi ;
|
||||
|
||||
: compose-all ( seq -- quot )
|
||||
[ ] [ compose ] reduce ;
|
||||
|
||||
EBNF: parse-brainfuck
|
||||
|
||||
inc-ptr = (">")+ => [[ length 1quotation [ (>) ] append ]]
|
||||
dec-ptr = ("<")+ => [[ length 1quotation [ (<) ] append ]]
|
||||
inc-mem = ("+")+ => [[ length 1quotation [ (+) ] append ]]
|
||||
dec-mem = ("-")+ => [[ length 1quotation [ (-) ] append ]]
|
||||
output = "." => [[ [ (.) ] ]]
|
||||
input = "," => [[ [ (,) ] ]]
|
||||
debug = "#" => [[ [ (#) ] ]]
|
||||
space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]]
|
||||
unknown = (.) => [[ "Invalid input" throw ]]
|
||||
|
||||
ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
|
||||
loop = "[" {loop|ops}+ "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
|
||||
|
||||
code = (loop|ops|unknown)* => [[ compose-all ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: run-brainfuck ( code -- )
|
||||
[ <brainfuck> ] swap parse-brainfuck [ drop flush ] 3append ;
|
||||
|
||||
: get-brainfuck ( code -- result )
|
||||
[ run-brainfuck ] with-string-writer ; inline
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Brainfuck programming language.
|
||||
|
|
@ -4,7 +4,8 @@
|
|||
USING: accessors arrays assocs combinators help help.crossref
|
||||
help.markup help.topics io io.streams.string kernel make namespaces
|
||||
parser prettyprint sequences summary help.vocabs
|
||||
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ;
|
||||
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
|
||||
listener ;
|
||||
|
||||
IN: fuel.help
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
USING: alien.c-types alien.syntax half-floats kernel tools.test ;
|
||||
IN: half-floats.tests
|
||||
|
||||
[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
|
||||
[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
|
||||
[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
|
||||
[ HEX: be00 ] [ -1.5 half>bits ] unit-test
|
||||
[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
|
||||
[ HEX: fe00 ] [ 0/0. half>bits ] unit-test
|
||||
|
||||
! too-big floats overflow to infinity
|
||||
[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
|
||||
[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
|
||||
|
||||
! too-small floats flush to zero
|
||||
[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
|
||||
[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
|
||||
|
||||
[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
|
||||
[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
|
||||
[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
|
||||
[ -1.5 ] [ HEX: be00 bits>half ] unit-test
|
||||
[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
|
||||
[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
|
||||
[ 0/0. ] [ HEX: 7e00 bits>half ] unit-test
|
||||
|
||||
C-STRUCT: halves
|
||||
{ "half" "tom" }
|
||||
{ "half" "dick" }
|
||||
{ "half" "harry" }
|
||||
{ "half" "harry-jr" } ;
|
||||
|
||||
[ 8 ] [ "halves" heap-size ] unit-test
|
||||
|
||||
[ 3.0 ] [
|
||||
"halves" <c-object>
|
||||
3.0 over set-halves-dick
|
||||
halves-dick
|
||||
] unit-test
|
||||
|
||||
[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
|
||||
[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.syntax kernel math math.order
|
||||
specialized-arrays.direct.functor specialized-arrays.functor ;
|
||||
IN: half-floats
|
||||
|
||||
: half>bits ( float -- bits )
|
||||
float>bits
|
||||
[ -31 shift 15 shift ] [
|
||||
HEX: 7fffffff bitand
|
||||
dup zero? [
|
||||
dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
|
||||
-13 shift
|
||||
112 10 shift -
|
||||
0 HEX: 7c00 clamp
|
||||
] if
|
||||
] unless
|
||||
] bi bitor ;
|
||||
|
||||
: bits>half ( bits -- float )
|
||||
[ -15 shift 31 shift ] [
|
||||
HEX: 7fff bitand
|
||||
dup zero? [
|
||||
dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
|
||||
13 shift
|
||||
112 23 shift +
|
||||
] if
|
||||
] unless
|
||||
] bi bitor bits>float ;
|
||||
|
||||
C-STRUCT: half { "ushort" "(bits)" } ;
|
||||
|
||||
<<
|
||||
|
||||
"half" c-type
|
||||
[ half>bits <ushort> ] >>unboxer-quot
|
||||
[ *ushort bits>half ] >>boxer-quot
|
||||
drop
|
||||
|
||||
"half" define-array
|
||||
"half" define-direct-array
|
||||
|
||||
>>
|
||||
|
|
@ -0,0 +1 @@
|
|||
Half-precision float support for FFI
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
#!/bin/bash
|
||||
|
||||
# change directories to a factor module
|
||||
function cdfactor {
|
||||
code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; "
|
||||
printf "\"%s\" <vocab> vocab-source-path (normalize-path) print" $1)
|
||||
echo $code > $HOME/.cdfactor
|
||||
fn=$(factor $HOME/.cdfactor)
|
||||
dn=$(dirname $fn)
|
||||
echo $dn
|
||||
if [ -z "$dn" ]; then
|
||||
echo "Warning: directory '$1' not found" 1>&2
|
||||
else
|
||||
cd $dn
|
||||
fi
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -125,7 +125,8 @@ code in the buffer."
|
|||
(defun factor-mode--indent-setter-line ()
|
||||
(when (fuel-syntax--at-setter-line)
|
||||
(save-excursion
|
||||
(let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation))))
|
||||
(let ((indent (and (fuel-syntax--at-constructor-line)
|
||||
(current-indentation))))
|
||||
(while (not (or indent
|
||||
(bobp)
|
||||
(fuel-syntax--at-begin-of-def)
|
||||
|
|
@ -225,6 +226,19 @@ code in the buffer."
|
|||
(defsubst factor-mode--cycling-setup ()
|
||||
(setq factor-mode--cycling-no-ask nil))
|
||||
|
||||
(defun factor-mode--code-file (kind &optional file)
|
||||
(let* ((file (or file (buffer-file-name)))
|
||||
(bn (file-name-nondirectory file)))
|
||||
(and (string-match (format "\\(.+\\)-%s\\.factor$" kind) bn)
|
||||
(expand-file-name (concat (match-string 1 bn) ".factor")
|
||||
(file-name-directory file)))))
|
||||
|
||||
(defsubst factor-mode--in-docs (&optional file)
|
||||
(factor-mode--code-file "docs"))
|
||||
|
||||
(defsubst factor-mode--in-tests (&optional file)
|
||||
(factor-mode--code-file "tests"))
|
||||
|
||||
(defun factor-mode-visit-other-file (&optional skip)
|
||||
"Cycle between code, tests and docs factor files.
|
||||
With prefix, non-existing files will be skipped."
|
||||
|
|
|
|||
|
|
@ -382,7 +382,7 @@
|
|||
(when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
|
||||
(push (list "Word" (match-string-no-properties 1)) rows)
|
||||
(forward-line))
|
||||
(while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
|
||||
(while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
|
||||
(let ((word `($link ,(match-string-no-properties 1)
|
||||
,(match-string-no-properties 1)
|
||||
word))
|
||||
|
|
|
|||
|
|
@ -172,7 +172,10 @@ interacting with a factor listener is at your disposal.
|
|||
(when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))
|
||||
|
||||
(setq fuel-stack-mode-string "/S")
|
||||
(when fuel-mode-stack-p (fuel-stack-mode fuel-mode)))
|
||||
(when fuel-mode-stack-p (fuel-stack-mode fuel-mode))
|
||||
|
||||
(when (and fuel-mode (not (file-exists-p (buffer-file-name))))
|
||||
(fuel-scaffold--maybe-insert)))
|
||||
|
||||
|
||||
;;; Keys:
|
||||
|
|
|
|||
|
|
@ -39,6 +39,64 @@
|
|||
(let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
|
||||
(defun fuel-scaffold--dev-name ()
|
||||
(or fuel-scaffold-developer-name
|
||||
(let ((cmd '(:fuel* (developer-name get :get) "fuel")))
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd)))
|
||||
"Your name"))
|
||||
|
||||
(defun fuel-scaffold--first-vocab ()
|
||||
(goto-char (point-min))
|
||||
(re-search-forward fuel-syntax--current-vocab-regex nil t))
|
||||
|
||||
(defsubst fuel-scaffold--vocab (file)
|
||||
(save-excursion
|
||||
(set-buffer (find-file-noselect file))
|
||||
(fuel-scaffold--first-vocab)
|
||||
(fuel-syntax--current-vocab)))
|
||||
|
||||
(defconst fuel-scaffold--tests-header-format
|
||||
"! Copyright (C) %s %s
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: %s tools.test ;
|
||||
IN: %s
|
||||
")
|
||||
|
||||
(defsubst fuel-scaffold--check-auto (var)
|
||||
(and var (or (eq var 'always) (y-or-n-p "Insert template? "))))
|
||||
|
||||
(defun fuel-scaffold--tests (parent)
|
||||
(when (and parent (fuel-scaffold--check-auto fuel-scaffold-test-autoinsert-p))
|
||||
(let ((year (format-time-string "%Y"))
|
||||
(name (fuel-scaffold--dev-name))
|
||||
(vocab (fuel-scaffold--vocab parent)))
|
||||
(insert (format fuel-scaffold--tests-header-format
|
||||
year name vocab vocab))
|
||||
t)))
|
||||
|
||||
(defsubst fuel-scaffold--create-docs (vocab)
|
||||
(let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
|
||||
"fuel")))
|
||||
(fuel-eval--send/wait cmd)))
|
||||
|
||||
(defun fuel-scaffold--help (parent)
|
||||
(when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p))
|
||||
(let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent)))
|
||||
(file (fuel-eval--retort-result ret)))
|
||||
(when file
|
||||
(revert-buffer t t t)
|
||||
(when (and fuel-scaffold-help-header-only-p
|
||||
(fuel-scaffold--first-vocab))
|
||||
(delete-region (1+ (point)) (point-max))
|
||||
(save-buffer))
|
||||
(message "Inserting template ... done."))
|
||||
(goto-char (point-min)))))
|
||||
|
||||
(defun fuel-scaffold--maybe-insert ()
|
||||
(ignore-errors
|
||||
(or (fuel-scaffold--tests (factor-mode--in-tests))
|
||||
(fuel-scaffold--help (factor-mode--in-docs)))))
|
||||
|
||||
|
||||
;;; User interface:
|
||||
|
||||
|
|
@ -73,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
|
|||
(interactive "P")
|
||||
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-completion--read-vocab nil)))
|
||||
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
|
||||
"fuel"))
|
||||
(ret (fuel-eval--send/wait cmd))
|
||||
(ret (fuel-scaffold--create-docs vocab))
|
||||
(file (fuel-eval--retort-result ret)))
|
||||
(unless file
|
||||
(error "Error creating help file" (car (fuel-eval--retort-error ret))))
|
||||
|
|
|
|||
|
|
@ -72,21 +72,67 @@
|
|||
(push (fuel-table--pad-row (reverse frow)) frows)))
|
||||
(reverse frows)))
|
||||
|
||||
(defvar fuel-table-corner-lt "┌")
|
||||
(defvar fuel-table-corner-lb "└")
|
||||
(defvar fuel-table-corner-rt "┐")
|
||||
(defvar fuel-table-corner-rb "┘")
|
||||
(defvar fuel-table-line "─")
|
||||
(defvar fuel-table-tee-t "┬")
|
||||
(defvar fuel-table-tee-b "┴")
|
||||
(defvar fuel-table-tee-l "├")
|
||||
(defvar fuel-table-tee-r "┤")
|
||||
(defvar fuel-table-crux "┼")
|
||||
(defvar fuel-table-sep "│")
|
||||
|
||||
(defun fuel-table--insert-line (widths first last sep)
|
||||
(insert first fuel-table-line)
|
||||
(dolist (w widths)
|
||||
(while (> w 0)
|
||||
(insert fuel-table-line)
|
||||
(setq w (1- w)))
|
||||
(insert fuel-table-line sep fuel-table-line))
|
||||
(delete-char -2)
|
||||
(insert fuel-table-line last)
|
||||
(newline))
|
||||
|
||||
(defun fuel-table--insert-first-line (widths)
|
||||
(fuel-table--insert-line widths
|
||||
fuel-table-corner-lt
|
||||
fuel-table-corner-rt
|
||||
fuel-table-tee-t))
|
||||
|
||||
(defun fuel-table--insert-middle-line (widths)
|
||||
(fuel-table--insert-line widths
|
||||
fuel-table-tee-l
|
||||
fuel-table-tee-r
|
||||
fuel-table-crux))
|
||||
|
||||
(defun fuel-table--insert-last-line (widths)
|
||||
(fuel-table--insert-line widths
|
||||
fuel-table-corner-lb
|
||||
fuel-table-corner-rb
|
||||
fuel-table-tee-b))
|
||||
|
||||
(defun fuel-table--insert-row (r)
|
||||
(let ((ln (length (car r)))
|
||||
(l 0))
|
||||
(while (< l ln)
|
||||
(insert (concat fuel-table-sep " "
|
||||
(mapconcat 'identity
|
||||
(mapcar `(lambda (x) (nth ,l x)) r)
|
||||
(concat " " fuel-table-sep " "))
|
||||
" " fuel-table-sep "\n"))
|
||||
(setq l (1+ l)))))
|
||||
|
||||
(defun fuel-table--insert (rows)
|
||||
(let* ((widths (fuel-table--col-widths rows))
|
||||
(rows (fuel-table--format-rows rows widths))
|
||||
(ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+")))
|
||||
(insert ls "\n")
|
||||
(rows (fuel-table--format-rows rows widths)))
|
||||
(fuel-table--insert-first-line widths)
|
||||
(dolist (r rows)
|
||||
(let ((ln (length (car r)))
|
||||
(l 0))
|
||||
(while (< l ln)
|
||||
(insert (concat "|" (mapconcat 'identity
|
||||
(mapcar `(lambda (x) (nth ,l x)) r)
|
||||
" |")
|
||||
" |\n"))
|
||||
(setq l (1+ l))))
|
||||
(insert ls "\n"))))
|
||||
(fuel-table--insert-row r)
|
||||
(fuel-table--insert-middle-line widths))
|
||||
(kill-line -1)
|
||||
(fuel-table--insert-last-line widths)))
|
||||
|
||||
|
||||
(provide 'fuel-table)
|
||||
|
|
|
|||
Loading…
Reference in New Issue