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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-06-03 11:03:45 -05:00
parent 0169934f6d 49f670be05
commit d951052ab1
35 changed files with 581 additions and 254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.stack-frame ;
IN: compiler.cfg.build-stack-frame
SYMBOL: frame-required?
SYMBOL: spill-counts
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
stack-frame [ max-stack-frame ] change ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _gc compute-stack-frame*
frame-required? on
stack-frame new swap gc-root-size>> >>gc-root-size
request-stack-frame ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
\ _spill t frame-required? set-word-prop
\ ##fixnum-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop
\ ##fixnum-add-tail f frame-required? set-word-prop
\ ##fixnum-sub-tail f frame-required? set-word-prop
\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
: insert-pro/epilogues ( insns -- insns )
[ [ insert-pro/epilogues* ] each ] { } make ;
: build-stack-frame ( mr -- mr )
[
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
] with-scope ;

0
basis/compiler/cfg/stack-frame/summary.txt → basis/compiler/cfg/build-stack-frame/summary.txt
View File

1
basis/compiler/cfg/builder/builder.factor
View File

@ -15,6 +15,7 @@ compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.alien ;
IN: compiler.cfg.builder

10
basis/compiler/cfg/def-use/def-use.factor
View File

@ -8,14 +8,6 @@ GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
M: ##unary/temp defs-vregs dst>> 1array ;
M: ##allot defs-vregs dst>> 1array ;
M: ##slot defs-vregs dst>> 1array ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst>> 1array ;
M: ##compare defs-vregs dst>> 1array ;
M: ##compare-imm defs-vregs dst>> 1array ;
M: ##compare-float defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@ -31,6 +23,7 @@ M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
@ -51,7 +44,6 @@ M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> ;
M: ##gc uses-vregs live-in>> ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;

7
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
cpu.architecture compiler.cfg.rpo
compiler.cfg.liveness compiler.cfg.instructions ;
compiler.cfg.liveness compiler.cfg.instructions
compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
@ -13,9 +14,7 @@ IN: compiler.cfg.gc-checks
: insert-gc-check ( basic-block -- )
dup gc? [
dup
[ swap object-pointer-regs \ ##gc new-insn prefix ]
change-instructions drop
[ i i f f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )

12
basis/compiler/cfg/instructions/instructions.factor
View File

@ -52,12 +52,6 @@ INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ;
INSN: ##call word { height integer } ;
INSN: ##jump word ;
@ -223,7 +217,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
INSN: ##gc live-in ;
INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
@ -243,6 +237,10 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src class n ;

34
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -58,17 +58,34 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if
] if ;
GENERIC: assign-registers-in-insn ( insn -- )
GENERIC: assign-before ( insn -- )
GENERIC: assign-after ( insn -- )
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
M: vreg-insn assign-registers-in-insn
M: vreg-insn assign-before
active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
M: insn assign-registers-in-insn drop ;
M: insn assign-before drop ;
: compute-live-registers ( -- regs )
active-intervals get seq>> [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
: compute-live-spill-slots ( -- spill-slots )
unhandled-intervals get
heap-values [ reload-from>> ] filter
[ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
M: ##gc assign-after
compute-live-registers >>live-registers
compute-live-spill-slots >>live-spill-slots
drop ;
M: insn assign-after drop ;
: <active-intervals> ( -- obj )
V{ } clone active-intervals boa ;
@ -82,10 +99,13 @@ M: insn assign-registers-in-insn drop ;
[
[
[
[ insn#>> activate-new-intervals ]
[ [ assign-registers-in-insn ] [ , ] bi ]
[ insn#>> expire-old-intervals ]
tri
{
[ insn#>> activate-new-intervals ]
[ assign-before ]
[ , ]
[ insn#>> expire-old-intervals ]
[ assign-after ]
} cleave
] each
] V{ } make
] change-instructions drop ;

21
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -242,11 +242,12 @@ SYMBOL: max-uses
max-insns get [ 0 ] replicate taken set
max-insns get [ dup ] H{ } map>assoc available set
[
live-interval new
\ live-interval new
swap int-regs swap vreg boa >>vreg
max-uses get random 2 max [ not-taken ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
dup uses>> last >>end
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
] map
] with-scope ;
@ -271,24 +272,6 @@ USING: math.private compiler.cfg.debugger ;
test-cfg first optimize-cfg linear-scan drop
] unit-test
[ f ] [
T{ basic-block
{ instructions
V{
T{ ##allot
f
T{ vreg f int-regs 1 }
40
array
T{ vreg f int-regs 2 }
f
}
}
}
} clone [ [ clone ] map ] change-instructions
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
] unit-test
[ 0 1 ] [
{
T{ live-interval

106
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -1,26 +1,56 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry
USING: namespaces kernel assocs accessors sequences math math.order fry
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use ;
compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
C: <live-range> live-range
TUPLE: live-interval
vreg
reg spill-to reload-from split-before split-after
start end uses
start end ranges uses
copy-from ;
: add-use ( n live-interval -- )
dup live-interval? [ "No def" throw ] unless
[ (>>end) ] [ uses>> push ] 2bi ;
ERROR: dead-value-error vreg ;
: <live-interval> ( start vreg -- live-interval )
live-interval new
: shorten-range ( n live-interval -- )
dup ranges>> empty?
[ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
: extend-range ( from to live-range -- )
ranges>> last
[ max ] change-to
[ min ] change-from
drop ;
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
: add-range ( from to live-interval -- )
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
: add-use ( n live-interval -- )
uses>> push ;
: <live-interval> ( vreg -- live-interval )
\ live-interval new
V{ } clone >>uses
swap >>vreg
over >>start
[ add-use ] keep ;
V{ } clone >>ranges
swap >>vreg ;
: block-from ( -- n )
basic-block get instructions>> first insn#>> ;
: block-to ( -- n )
basic-block get instructions>> last insn#>> ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
@ -31,23 +61,31 @@ M: live-interval clone
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: new-live-interval ( n vreg live-intervals -- )
2dup key? [
at add-use
] [
[ [ <live-interval> ] keep ] dip set-at
] if ;
: live-interval ( vreg live-intervals -- live-interval )
[ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
: handle-output ( n vreg live-intervals -- )
live-interval
[ add-use ] [ shorten-range ] 2bi ;
: handle-input ( n vreg live-intervals -- )
live-interval
[ [ block-from ] 2dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- )
live-interval
[ dupd add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
[ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
[ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: record-copy ( insn -- )
@ -59,8 +97,32 @@ M: ##copy compute-live-intervals*
M: ##copy-float compute-live-intervals*
[ call-next-method ] [ record-copy ] bi ;
: handle-live-out ( bb -- )
live-out keys block-from block-to live-intervals get '[
[ _ _ ] dip _ live-interval add-range
] each ;
: compute-live-intervals-step ( bb -- )
[ basic-block set ]
[ handle-live-out ]
[ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
[
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
tri
] each ;
: compute-live-intervals ( rpo -- live-intervals )
H{ } clone [
live-intervals set
[ instructions>> [ compute-live-intervals* ] each ] each
] keep values ;
<reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;

55
basis/compiler/cfg/linearization/linearization.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
combinators assocs
cpu.architecture
combinators assocs arrays locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.stack-frame
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
@ -68,6 +68,57 @@ M: ##dispatch linearize-insn
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
: gc-root-registers ( n live-registers -- n )
[
[ second 2array , ]
[ first reg-class>> reg-size + ]
2bi
] each ;
: gc-root-spill-slots ( n live-spill-slots -- n )
[
dup first reg-class>> int-regs eq? [
[ second <spill-slot> 2array , ]
[ first reg-class>> reg-size + ]
2bi
] [ drop ] if
] each ;
: oop-registers ( regs -- regs' )
[ first reg-class>> int-regs eq? ] filter ;
: data-registers ( regs -- regs' )
[ first reg-class>> double-float-regs eq? ] filter ;
:: compute-gc-roots ( live-registers live-spill-slots -- alist )
[
0
! we put float registers last; the GC doesn't actually scan them
live-registers oop-registers gc-root-registers
live-spill-slots gc-root-spill-slots
live-registers data-registers gc-root-registers
drop
] { } make ;
: count-gc-roots ( live-registers live-spill-slots -- n )
! Size of GC root area, minus the float registers
[ oop-registers length ] bi@ + ;
M: ##gc linearize-insn
nip
[
[ temp1>> ]
[ temp2>> ]
[
[ live-registers>> ] [ live-spill-slots>> ] bi
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
2tri
] tri
_gc
] with-regs ;
: linearize-basic-blocks ( cfg -- insns )
[
[ [ linearize-basic-block ] each-basic-block ]

2
basis/compiler/cfg/mr/mr.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.cfg.rpo ;
compiler.cfg.build-stack-frame compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )

1
basis/compiler/cfg/stack-frame/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

107
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,72 +1,55 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
compiler.cfg.instructions compiler.cfg.registers ;
USING: math math.order namespaces accessors kernel layouts combinators
combinators.smart assocs sequences cpu.architecture ;
IN: compiler.cfg.stack-frame
SYMBOL: frame-required?
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
{ gc-root-size integer }
spill-counts ;
SYMBOL: spill-counts
! Stack frame utilities
: param-base ( -- n )
stack-frame get [ params>> ] [ return>> ] bi + ;
GENERIC: compute-stack-frame* ( insn -- )
: spill-float-offset ( n -- offset )
double-float-regs reg-size * ;
: spill-integer-base ( -- n )
stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
param-base + ;
: spill-integer-offset ( n -- offset )
cells spill-integer-base + ;
: spill-area-size ( stack-frame -- n )
spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
: gc-root-base ( -- n )
stack-frame get spill-area-size
param-base + ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
: gc-roots-size ( live-registers live-spill-slots -- n )
[ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
: (stack-frame-size) ( stack-frame -- n )
[
{
[ spill-area-size ]
[ gc-root-size>> ]
[ params>> ]
[ return>> ]
} cleave
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
2bi ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> stack-frame [ max-stack-frame ] change ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
\ _spill t frame-required? set-word-prop
\ ##gc t frame-required? set-word-prop
\ ##fixnum-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop
\ ##fixnum-add-tail f frame-required? set-word-prop
\ ##fixnum-sub-tail f frame-required? set-word-prop
\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
: insert-pro/epilogues ( insns -- insns )
[ [ insert-pro/epilogues* ] each ] { } make ;
: build-stack-frame ( mr -- mr )
[
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
] with-scope ;
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
2tri ;

19
basis/compiler/codegen/codegen.factor
View File

@ -10,6 +10,7 @@ compiler.errors
compiler.alien
compiler.cfg
compiler.cfg.instructions
compiler.cfg.stack-frame
compiler.cfg.registers
compiler.cfg.builder
compiler.codegen.fixup
@ -234,7 +235,13 @@ M: ##write-barrier generate-insn
[ table>> register ]
tri %write-barrier ;
M: ##gc generate-insn drop %gc ;
M: _gc generate-insn
{
[ temp1>> register ]
[ temp2>> register ]
[ gc-roots>> ]
[ gc-root-count>> ]
} cleave %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
@ -243,16 +250,6 @@ M: ##alien-global generate-insn
%alien-global ;
! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;

9
basis/compiler/tests/codegen.factor
View File

@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
combinators vectors grouping make alien.c-types ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -282,3 +282,10 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
-1 <int> -1 <int>
[ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test

7
basis/compression/run-length/run-length.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays grouping sequences ;
IN: compression.run-length
: run-length-uncompress8 ( byte-array -- byte-array' )
2 group [ first2 <array> ] map concat ;

18
basis/cpu/architecture/architecture.factor
View File

@ -12,12 +12,22 @@ SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop cell ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
@ -119,7 +129,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %gc cpu ( -- )
HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )

5
basis/cpu/x86/32/32.factor
View File

@ -3,10 +3,11 @@
USING: locals alien.c-types alien.syntax arrays kernel
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture compiler compiler.units
cpu.x86 cpu.architecture make compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.intrinsics make ;
compiler.cfg.builder compiler.cfg.intrinsics
compiler.cfg.stack-frame ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.

4
basis/cpu/x86/64/64.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics ;
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
IN: cpu.x86.64
M: x86.64 machine-registers

172
basis/cpu/x86/x86.factor
View File

@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.intrinsics
compiler.codegen compiler.codegen.fixup ;
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86
<< enable-fixnum-log2 >>
@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
M: x86 two-operand? t ;
HOOK: stack-reg cpu ( -- reg )
HOOK: reserved-area-size cpu ( -- n )
: stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
: spill-float@ ( n -- op ) spill-float-offset param@ ;
: gc-root@ ( n -- op ) gc-root-offset param@ ;
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
M: x86 stack-frame-size ( stack-frame -- i )
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
: align-stack ( n -- n' )
os macosx? cpu x86.64? or [ 16 align ] when ;
HOOK: reserved-area-size cpu ( -- n )
M: x86 stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
[ params>> ]
[ return>> ]
tri + +
3 cells +
reserved-area-size +
align-stack ;
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n )
@ -315,17 +327,29 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label
] with-scope ;
: small-reg-4 ( reg -- reg' )
: small-reg-8 ( reg -- reg' )
H{
{ EAX EAX }
{ ECX ECX }
{ EDX EDX }
{ EBX EBX }
{ ESP ESP }
{ EBP EBP }
{ ESI ESP }
{ EDI EDI }
{ EAX RAX }
{ ECX RCX }
{ EDX RDX }
{ EBX RBX }
{ ESP RSP }
{ EBP RBP }
{ ESI RSP }
{ EDI RDI }
{ RAX RAX }
{ RCX RCX }
{ RDX RDX }
{ RBX RBX }
{ RSP RSP }
{ RBP RBP }
{ RSI RSP }
{ RDI RDI }
} at ; inline
: small-reg-4 ( reg -- reg' )
small-reg-8 H{
{ RAX EAX }
{ RCX ECX }
{ RDX EDX }
@ -361,12 +385,21 @@ M:: x86 %box-alien ( dst src temp -- )
{ 1 [ small-reg-1 ] }
{ 2 [ small-reg-2 ] }
{ 4 [ small-reg-4 ] }
{ 8 [ small-reg-8 ] }
} case ;
: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
HOOK: small-regs cpu ( -- regs )
M: x86.32 small-regs { EAX ECX EDX EBX } ;
M: x86.64 small-regs { RAX RCX RDX RBX } ;
HOOK: small-reg-native cpu ( reg -- reg' )
M: x86.32 small-reg-native small-reg-4 ;
M: x86.64 small-reg-native small-reg-8 ;
: small-reg-that-isn't ( exclude -- reg' )
small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
@ -376,7 +409,7 @@ M:: x86 %box-alien ( dst src temp -- )
#! call the quot with that. Otherwise, we find a small
#! register that is not in exclude, and call quot, saving
#! and restoring the small register.
dst small-reg-4 small-regs memq? [ dst quot call ] [
dst small-reg-native small-regs memq? [ dst quot call ] [
exclude small-reg-that-isn't
[ quot call ] with-save/restore
] if ; inline
@ -492,29 +525,58 @@ M:: x86 %write-barrier ( src card# table -- )
table table [] MOV
table card# [+] card-mark <byte> MOV ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
:: check-nursery ( temp1 temp2 -- )
temp1 load-zone-ptr
temp2 temp1 cell [+] MOV
temp2 1024 ADD
temp1 temp1 3 cells [+] MOV
temp2 temp1 CMP ;
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
temp spill-slot n>> spill-integer@ MOV
gc-root gc-root@ temp MOV ;
M:: word save-gc-root ( gc-root register temp -- )
gc-root gc-root@ register MOV ;
: save-gc-roots ( gc-roots temp -- )
'[ _ save-gc-root ] assoc-each ;
GENERIC# load-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
temp gc-root gc-root@ MOV
spill-slot n>> spill-integer@ temp MOV ;
M:: word load-gc-root ( gc-root register temp -- )
register gc-root gc-root@ MOV ;
: load-gc-roots ( gc-roots temp -- )
'[ _ load-gc-root ] assoc-each ;
:: call-gc ( gc-root-count -- )
! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"inline_gc" f %alien-invoke ;
M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
"end" define-label
temp1 temp2 check-nursery
"end" get JLE
gc-roots temp1 save-gc-roots
gc-root-count call-gc
gc-roots temp1 load-gc-roots
"end" resolve-label ;
M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
HOOK: stack-reg cpu ( -- reg )
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
@ -568,28 +630,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
{ cc/= [ JNE ] }
} case ;
: stack@ ( n -- op ) stack-reg swap [+] ;
: param@ ( n -- op ) reserved-area-size + stack@ ;
: spill-integer-base ( stack-frame -- n )
[ params>> ] [ return>> ] bi + reserved-area-size + ;
: spill-integer@ ( n -- op )
cells
stack-frame get spill-integer-base
+ stack@ ;
: spill-float-base ( stack-frame -- n )
[ spill-integer-base ]
[ spill-counts>> int-regs swap at int-regs reg-size * ]
bi + ;
: spill-float@ ( n -- op )
double-float-regs reg-size *
stack-frame get spill-float-base
+ stack@ ;
M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;

3
basis/heaps/heaps.factor
View File

@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
[ dup heap-pop swap 2array ]
produce nip ;
: heap-values ( heap -- alist )
data>> [ value>> ] { } map-as ;
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi

3
basis/images/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Doug Coleman
Daniel Ehrenberg

43
basis/images/bitmap/bitmap.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary locals ;
combinators compression.run-length endian fry grouping images
images.loader io io.binary io.encodings.binary io.files kernel
locals macros math math.bitwise math.functions namespaces
sequences strings summary ;
IN: images.bitmap
: assert-sequence= ( a b -- )
@ -21,7 +22,8 @@ TUPLE: bitmap-image < image ;
TUPLE: loading-bitmap
size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index ;
x-pels y-pels color-used color-important color-palette color-index
uncompressed-bytes ;
ERROR: bitmap-magic magic ;
@ -31,7 +33,7 @@ M: bitmap-magic summary
<PRIVATE
: 8bit>buffer ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
@ -39,7 +41,7 @@ ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
<sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
: bitmap>bytes ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
@ -48,6 +50,21 @@ ERROR: bmp-not-supported n ;
[ bmp-not-supported ]
} case >byte-array ;
ERROR: unsupported-bitmap-compression compression ;
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
dup compression>> {
{ 0 [ ] }
{ 1 [ [ run-length-uncompress8 ] change-color-index ] }
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
{ 3 [ "bitfields" unsupported-bitmap-compression ] }
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
{ 5 [ "png" unsupported-bitmap-compression ] }
} case ;
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ;
: parse-file-header ( loading-bitmap -- loading-bitmap )
2 read "BM" assert-sequence=
read4 >>size
@ -67,7 +84,7 @@ ERROR: bmp-not-supported n ;
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( loading-bitmap -- n )
: color-palette-length ( loading-bitmap -- n )
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( loading-bitmap -- n )
@ -98,11 +115,11 @@ ERROR: bmp-not-supported n ;
] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-palette-length read >>color-palette
dup color-index-length read >>color-index
fixup-color-index ;
: load-bitmap-data ( path -- loading-bitmap )
: load-bitmap ( path -- loading-bitmap )
binary [
loading-bitmap new
parse-file-header parse-bitmap-header parse-bitmap
@ -120,14 +137,16 @@ ERROR: unknown-component-order bitmap ;
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
{
[ raw-bitmap>seq >>bitmap ]
[ loading-bitmap>bytes >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ height>> 0 < [ t >>upside-down? ] when ]
[ bitmap>component-order >>component-order ]
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
swap load-bitmap-data loading-bitmap>bitmap-image ;
swap load-bitmap loading-bitmap>bitmap-image ;
"bmp" bitmap-image register-image-class
PRIVATE>
@ -183,7 +202,7 @@ PRIVATE>
! color-important
[ drop 0 write4 ]
! rgb-quads
! color-palette
[
[ bitmap>color-index ]
[ dim>> first 3 * ]

29
basis/images/images-tests.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: images tools.test kernel accessors ;
IN: images.tests
[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
0 0 0 0
0 0 0 0
0 0 0 0
57 57 57 255
0 0 0 0
0 0 0 0
} } pixel-at ] unit-test
[ B{
0 0 0 0
0 0 0 0
0 0 0 0
57 57 57 255
0 0 0 0
0 0 0 0
} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
0 0 0 0
0 0 0 0
0 0 0 0
0 0 0 0
0 0 0 0
0 0 0 0
} } [ set-pixel-at ] keep bitmap>> ] unit-test

29
basis/images/images.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel accessors ;
USING: combinators kernel accessors sequences math arrays ;
IN: images
SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
@ -35,3 +35,28 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path tuple -- image )
: make-image ( bitmap -- image )
! bitmap is a sequence of sequences of pixels which are RGBA
<image>
over [ first length ] [ length ] bi 2array >>dim
RGBA >>component-order
swap concat concat B{ } like >>bitmap ;
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
[ dim>> first * + ]
[ component-order>> bytes-per-pixel [ * dup ] keep + ]
[ bitmap>> ] tri ;
: set-subseq ( new-value from to victim -- )
<slice> 0 swap copy ; inline
PRIVATE>
: pixel-at ( x y image -- pixel )
pixel@ subseq ;
: set-pixel-at ( pixel x y image -- )
pixel@ set-subseq ;

4
basis/images/jpeg/jpeg.factor
View File

@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep ;
sequences sequences.deep images.loader ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
@ -302,3 +302,5 @@ PRIVATE>
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

24
basis/images/loader/loader.factor
View File

@ -1,22 +1,22 @@
! Copyright (C) 2009 Doug Coleman.
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images io.pathnames
images.png ;
accessors images io.pathnames namespaces assocs ;
IN: images.loader
ERROR: unknown-image-extension extension ;
<PRIVATE
SYMBOL: types
types [ H{ } clone ] initialize
: image-class ( path -- class )
file-extension >lower {
{ "bmp" [ bitmap-image ] }
{ "tif" [ tiff-image ] }
{ "tiff" [ tiff-image ] }
! { "jpg" [ jpeg-image ] }
! { "jpeg" [ jpeg-image ] }
{ "png" [ png-image ] }
[ unknown-image-extension ]
} case ;
file-extension >lower types get ?at
[ unknown-image-extension ] unless ;
PRIVATE>
: register-image-class ( extension class -- )
swap types get set-at ;
: load-image ( path -- image )
dup image-class new load-image* ;

5
basis/images/png/png.factor
View File

@ -3,7 +3,8 @@
USING: accessors constructors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
sequences io.streams.limited fry combinators arrays math
checksums checksums.crc32 compression.inflate grouping byte-arrays ;
checksums checksums.crc32 compression.inflate grouping byte-arrays
images.loader ;
IN: images.png
TUPLE: png-image < image chunks
@ -115,3 +116,5 @@ ERROR: unimplemented-color-type image ;
M: png-image load-image*
drop load-png ;
"png" png-image register-image-class

5
basis/images/tiff/tiff.factor
View File

@ -5,7 +5,8 @@ compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors specialized-arrays.float locals ;
strings math.vectors specialized-arrays.float locals
images.loader ;
IN: images.tiff
TUPLE: tiff-image < image ;
@ -561,3 +562,5 @@ ERROR: unknown-component-order ifd ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each

6
basis/math/bits/bits-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup math ;
USING: help.syntax help.markup math sequences ;
IN: math.bits
ABOUT: "math.bits"
@ -24,3 +24,7 @@ HELP: make-bits
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
} ;
HELP: unbits
{ $values { "seq" sequence } { "number" integer } }
{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ;

3
basis/math/bits/bits-tests.factor
View File

@ -29,3 +29,6 @@ IN: math.bits.tests
[ t ] [
1067811677921310779 >bignum make-bits last
] unit-test
[ 6 ] [ 6 make-bits unbits ] unit-test
[ 6 ] [ 6 3 <bits> >array unbits ] unit-test

3
basis/math/bits/bits.factor
View File

@ -14,3 +14,6 @@ M: bits length length>> ;
M: bits nth-unsafe number>> swap bit? ;
INSTANCE: bits immutable-sequence
: unbits ( seq -- number )
<reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;

4
basis/ui/images/images.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces cache images images.loader accessors assocs
kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
memoize ;
memoize images.tiff ;
IN: ui.images
TUPLE: image-name path ;
@ -29,4 +29,4 @@ PRIVATE>
rendered-image draw-scaled-texture ;
: image-dim ( image-name -- dim )
cached-image dim>> ;
cached-image dim>> ;

8
vm/data_gc.cpp
View File

@ -680,9 +680,15 @@ PRIMITIVE(become)
compile_all_words();
}
VM_C_API void minor_gc()
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
gc_local_push((cell)&gc_roots_base[i]);
garbage_collection(data->nursery(),false,0);
for(cell i = 0; i < gc_roots_size; i++)
gc_local_pop();
}
}

2
vm/data_gc.hpp
View File

@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
#endif
}
VM_C_API void minor_gc();
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
}