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

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2009-07-31 16:38:46 +02:00
parent ac1e92d376 5e6936ec69
commit 58ec3bda05
41 changed files with 869 additions and 650 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
README.txt
View File

@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
Pango, X11, and OpenGL. On a Debian-derived Linux distribution Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything: (like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev sudo apt-get install libc6-dev libpango1.0-dev libx11-dev libgl1-mesa-dev
Note that if you are using a proprietary OpenGL driver, you should
probably leave out the last package in the list.
If your DISPLAY environment variable is set, the UI will start If your DISPLAY environment variable is set, the UI will start
automatically: automatically when you run Factor:
./factor ./factor

39
basis/bootstrap/compiler/compiler.factor
View File

@ -6,11 +6,14 @@ classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io growable namespaces.private assocs words command-line vocabs io
io.encodings.string libc splitting math.parser memory compiler.units io.encodings.string libc splitting math.parser memory compiler.units
math.order compiler.tree.builder compiler.tree.optimizer math.order quotations quotations.private assocs.private ;
compiler.cfg.optimizer ; FROM: compiler => enable-optimizer ;
FROM: compiler => enable-optimizer compile-word ;
IN: bootstrap.compiler IN: bootstrap.compiler
"profile-compiler" get [
"bootstrap.compiler.timing" require
] when
! Don't bring this in when deploying, since it will store a ! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable ! reference to 'eval' in a global variable
"deploy-vocab" get "staging" get or [ "deploy-vocab" get "staging" get or [
@ -42,16 +45,24 @@ nl
! which are also quick to compile are replaced by ! which are also quick to compile are replaced by
! compiled definitions as soon as possible. ! compiled definitions as soon as possible.
{ {
not not ?
2over roll -roll
array? hashtable? vector? array? hashtable? vector?
tuple? sbuf? tombstone? tuple? sbuf? tombstone?
curry? compose? callable?
quotation?
array-nth set-array-nth curry compose uncurry
array-nth set-array-nth length>>
wrap probe wrap probe
namestack* namestack*
layout-of
} compile-unoptimized } compile-unoptimized
"." write flush "." write flush
@ -75,7 +86,7 @@ nl
"." write flush "." write flush
{ {
hashcode* = get set hashcode* = equal? assoc-stack (assoc-stack) get set
} compile-unoptimized } compile-unoptimized
"." write flush "." write flush
@ -100,22 +111,6 @@ nl
"." write flush "." write flush
{ build-tree } compile-unoptimized
"." write flush
{ optimize-tree } compile-unoptimized
"." write flush
{ optimize-cfg } compile-unoptimized
"." write flush
{ compile-word } compile-unoptimized
"." write flush
vocabs [ words compile-unoptimized "." write flush ] each vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush " done" print flush

38
basis/bootstrap/compiler/timing/timing.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler.cfg.builder compiler.cfg.linear-scan
compiler.cfg.liveness compiler.cfg.mr compiler.cfg.optimizer
compiler.cfg.stacks.finalize compiler.cfg.stacks.global
compiler.codegen compiler.tree.builder compiler.tree.optimizer
kernel make sequences tools.annotations tools.crossref ;
IN: bootstrap.compiler.timing
: passes ( word -- seq )
def>> uses [ vocabulary>> "compiler." head? ] filter ;
: high-level-passes ( -- seq ) \ optimize-tree passes ;
: low-level-passes ( -- seq ) \ optimize-cfg passes ;
: machine-passes ( -- seq ) \ build-mr passes ;
: linear-scan-passes ( -- seq ) \ (linear-scan) passes ;
: all-passes ( -- seq )
[
\ build-tree ,
\ optimize-tree ,
high-level-passes %
\ build-cfg ,
\ compute-global-sets ,
\ finalize-stack-shuffling ,
\ optimize-cfg ,
low-level-passes %
\ compute-live-sets ,
\ build-mr ,
machine-passes %
linear-scan-passes %
\ generate ,
] { } make ;
all-passes [ [ reset ] [ add-timing ] bi ] each

26
basis/compiler/cfg/gc-checks/gc-checks-tests.factor Normal file
View File

@ -0,0 +1,26 @@
IN: compiler.cfg.gc-checks.tests
USING: compiler.cfg.gc-checks compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
: test-gc-checks ( -- )
cfg new 0 get >>entry
compute-predecessors
insert-gc-checks
drop ;
V{
T{ ##inc-d f 3 }
T{ ##replace f V int-regs 0 D 1 }
} 0 test-bb
V{
T{ ##box-float f V int-regs 0 V int-regs 1 }
} 1 test-bb
0 get 1 get 1vector >>successors drop
[ ] [ test-gc-checks ] unit-test
[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test

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

@ -1,17 +1,27 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs USING: accessors kernel sequences assocs fry
compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.hats ; compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.gc-checks IN: compiler.cfg.gc-checks
: gc? ( bb -- ? ) : insert-gc-check? ( bb -- ? )
instructions>> [ ##allocation? ] any? ; instructions>> [ ##allocation? ] any? ;
: insert-gc-check ( basic-block -- ) : blocks-with-gc ( cfg -- bbs )
dup gc? [ post-order [ insert-gc-check? ] filter ;
[ i i f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ; : insert-gc-check ( bb -- )
dup '[
i i f _ uninitialized-locs \ ##gc new-insn
prefix
] change-instructions drop ;
: insert-gc-checks ( cfg -- cfg' ) : insert-gc-checks ( cfg -- cfg' )
dup [ insert-gc-check ] each-basic-block ; dup blocks-with-gc [
over compute-uninitialized-sets
[ insert-gc-check ] each
] unless-empty ;

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

@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ; INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ; INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##gc temp1 temp2 live-values ; INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
! Instructions used by machine IR only. ! Instructions used by machine IR only.
INSN: _prologue stack-frame ; INSN: _prologue stack-frame ;
@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ; INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
! These instructions operate on machine registers and not ! These instructions operate on machine registers and not
! virtual registers ! virtual registers

14
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
slots.private:set-slot slots.private:set-slot
strings.private:string-nth strings.private:string-nth
strings.private:set-string-nth-fast strings.private:set-string-nth-fast
! classes.tuple.private:<tuple-boa> classes.tuple.private:<tuple-boa>
! arrays:<array> arrays:<array>
! byte-arrays:<byte-array> byte-arrays:<byte-array>
! byte-arrays:(byte-array) byte-arrays:(byte-array)
! kernel:<wrapper> kernel:<wrapper>
alien.accessors:alien-unsigned-1 alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1 alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1 alien.accessors:alien-signed-1
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-unsigned-2 alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2 alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2 alien.accessors:set-alien-signed-2
! alien.accessors:alien-cell alien.accessors:alien-cell
alien.accessors:set-alien-cell alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each } [ t "intrinsic" set-word-prop ] each
@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-float alien.accessors:set-alien-float
alien.accessors:alien-double alien.accessors:alien-double
alien.accessors:set-alien-double alien.accessors:set-alien-double
} drop f [ t "intrinsic" set-word-prop ] each ; } [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum-log2 ( -- ) : enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

18
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -28,29 +28,11 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? ) : no-free-registers? ( result -- ? )
second 0 = ; inline second 0 = ; inline
: split-to-fit ( new n -- before after )
split-interval
[ [ compute-start/end ] bi@ ]
[ >>split-next drop ]
[ ]
2tri ;
: register-partially-available ( new result -- )
{
{ [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] }
{ [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] }
[
[ second 1 - split-to-fit ] keep
'[ _ register-available ] [ add-unhandled ] bi*
]
} cond ;
: assign-register ( new -- ) : assign-register ( new -- )
dup coalesce? [ coalesce ] [ dup coalesce? [ coalesce ] [
dup register-status { dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] } { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] } { [ 2dup register-available? ] [ register-available ] }
! [ register-partially-available ]
[ drop assign-blocked-register ] [ drop assign-blocked-register ]
} cond } cond
] if ; ] if ;

90
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -28,23 +28,42 @@ ERROR: bad-live-ranges interval ;
[ swap first (>>from) ] [ swap first (>>from) ]
2bi ; 2bi ;
: split-for-spill ( live-interval n -- before after )
split-interval
{
[ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
[ [ compute-start/end ] bi@ ]
[ [ check-ranges ] bi@ ]
[ ]
} 2cleave ;
: assign-spill ( live-interval -- ) : assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ; dup vreg>> assign-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
! then it is the second child of an interval that was split. We reload
! the value and let the resolve pass insert a split later.
dup uses>> empty? [ drop f ] [
{
[ ]
[ assign-spill ]
[ trim-before-ranges ]
[ compute-start/end ]
[ check-ranges ]
} cleave
] if ;
: assign-reload ( live-interval -- ) : assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ; dup vreg>> assign-spill-slot >>reload-from drop ;
: split-and-spill ( live-interval n -- before after ) : spill-after ( after -- after/f )
split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ; ! If the interval has no more usages after the spill location,
! then it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
dup uses>> empty? [ drop f ] [
{
[ ]
[ assign-reload ]
[ trim-after-ranges ]
[ compute-start/end ]
[ check-ranges ]
} cleave
] if ;
: split-for-spill ( live-interval n -- before after )
split-interval [ spill-before ] [ spill-after ] bi* ;
: find-use-position ( live-interval new -- n ) : find-use-position ( live-interval new -- n )
[ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
@ -72,47 +91,12 @@ ERROR: bad-live-ranges interval ;
[ uses>> first ] [ second ] bi* > ; [ uses>> first ] [ second ] bi* > ;
: spill-new ( new pair -- ) : spill-new ( new pair -- )
drop drop spill-after add-unhandled ;
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
: spill-live-out ( live-interval -- )
! The interval has no more usages after the spill location. This
! means it is the first child of an interval that was split. We
! spill the value and let the resolve pass insert a reload later.
{
[ trim-before-ranges ]
[ compute-start/end ]
[ assign-spill ]
[ add-handled ]
} cleave ;
: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ;
: spill-live-in ( live-interval -- )
! The interval does not have any usages before the spill location.
! This means it is the second child of an interval that was
! split. We reload the value and let the resolve pass insert a
! split later.
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: spill ( live-interval n -- ) : spill ( live-interval n -- )
{ split-for-spill
{ [ 2dup spill-live-out? ] [ drop spill-live-out ] } [ [ add-handled ] when* ]
{ [ 2dup spill-live-in? ] [ drop spill-live-in ] } [ [ add-unhandled ] when* ] bi* ;
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ;
:: spill-intersecting-active ( new reg -- ) :: spill-intersecting-active ( new reg -- )
! If there is an active interval using 'reg' (there should be at ! If there is an active interval using 'reg' (there should be at
@ -149,8 +133,8 @@ ERROR: bad-live-ranges interval ;
! A register would be available for part of the new ! A register would be available for part of the new
! interval's lifetime if all active and inactive intervals ! interval's lifetime if all active and inactive intervals
! using that register were split and spilled. ! using that register were split and spilled.
[ second 1 - split-and-spill add-unhandled ] keep [ second 1 - split-for-spill [ add-unhandled ] when* ] keep
spill-available ; '[ _ spill-available ] when* ;
: assign-blocked-register ( new -- ) : assign-blocked-register ( new -- )
dup spill-status { dup spill-status {

4
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

@ -27,9 +27,6 @@ IN: compiler.cfg.linear-scan.allocation.splitting
: split-uses ( uses n -- before after ) : split-uses ( uses n -- before after )
'[ _ <= ] partition ; '[ _ <= ] partition ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ; inline
ERROR: splitting-too-early ; ERROR: splitting-too-early ;
ERROR: splitting-too-late ; ERROR: splitting-too-late ;
@ -56,7 +53,6 @@ ERROR: splitting-atomic-interval ;
live-interval clone :> after live-interval clone :> after
live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* 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 ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
live-interval before after record-split
before split-before before split-before
after split-after ; after split-after ;

17
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -5,25 +5,12 @@ namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg assocs ; compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- )
[
reg>>
[ "Not all intervals have registers" throw ] unless
] each ;
: split-children ( live-interval -- seq )
dup split-before>> [
[ split-before>> ] [ split-after>> ] bi
[ split-children ] bi@
append
] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- ) : check-linear-scan ( live-intervals machine-registers -- )
[ [
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set live-intervals set
] dip allocate-registers ] dip
[ split-children ] map concat check-assigned ; allocate-registers drop ;
: picture ( uses -- str ) : picture ( uses -- str )
dup last 1 + CHAR: space <string> dup last 1 + CHAR: space <string>

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

@ -75,6 +75,9 @@ check-numbering? on
{ T{ live-range f 0 5 } } 0 split-ranges { T{ live-range f 0 5 } } 0 split-ranges
] unit-test ] unit-test
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
H{ } spill-slots set
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -82,6 +85,7 @@ check-numbering? on
{ end 2 } { end 2 }
{ uses V{ 0 1 } } { uses V{ 0 1 } }
{ ranges V{ T{ live-range f 0 2 } } } { ranges V{ T{ live-range f 0 2 } } }
{ spill-to 10 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -89,6 +93,7 @@ check-numbering? on
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
{ ranges V{ T{ live-range f 5 5 } } } { ranges V{ T{ live-range f 5 5 } } }
{ reload-from 10 }
} }
] [ ] [
T{ live-interval T{ live-interval
@ -97,82 +102,61 @@ check-numbering? on
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill [ f >>split-next ] bi@ } 2 split-for-spill
] unit-test ] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 11 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 1 } { start 1 }
{ end 5 } { end 5 }
{ uses V{ 1 5 } } { uses V{ 1 5 } }
{ ranges V{ T{ live-range f 1 5 } } } { ranges V{ T{ live-range f 1 5 } } }
{ reload-from 11 }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 } { start 0 }
{ end 5 } { end 5 }
{ uses V{ 0 1 5 } } { uses V{ 0 1 5 } }
{ ranges V{ T{ live-range f 0 5 } } } { ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill [ f >>split-next ] bi@ } 0 split-for-spill
] unit-test ] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 0 } { start 0 }
{ end 1 } { end 1 }
{ uses V{ 0 } } { uses V{ 0 } }
{ ranges V{ T{ live-range f 0 1 } } } { ranges V{ T{ live-range f 0 1 } } }
{ spill-to 12 }
} }
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 20 } { start 20 }
{ end 30 } { end 30 }
{ uses V{ 20 30 } } { uses V{ 20 30 } }
{ ranges V{ T{ live-range f 20 30 } } } { ranges V{ T{ live-range f 20 30 } } }
{ reload-from 12 }
} }
] [ ] [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 0 } { start 0 }
{ end 30 } { end 30 }
{ uses V{ 0 20 30 } } { uses V{ 0 20 30 } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill [ f >>split-next ] bi@ } 10 split-for-spill
] unit-test
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 4 }
{ uses V{ 0 1 4 } }
{ ranges V{ T{ live-range f 0 4 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 10 }
{ uses V{ 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 4 5 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
} 4 split-to-fit [ f >>split-next ] bi@
] unit-test ] unit-test
[ [
@ -352,6 +336,78 @@ check-numbering? on
check-linear-scan check-linear-scan
] must-fail ] must-fail
! Problem with spilling intervals with no more usages after the spill location
[ ] [
{
T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg T{ vreg { n 2 } { reg-class int-regs } } }
{ start 0 }
{ end 20 }
{ uses V{ 0 10 20 } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
{ vreg T{ vreg { n 3 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 6 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
{ vreg T{ vreg { n 4 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
! This guy will invoke the 'spill partially available' code path
T{ live-interval
{ vreg T{ vreg { n 5 } { reg-class int-regs } } }
{ start 4 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
H{ { int-regs { "A" "B" } } }
check-linear-scan
] unit-test
! Test spill-new code path
[ ] [
{
T{ live-interval
{ vreg T{ vreg { n 1 } { reg-class int-regs } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 6 10 } }
{ ranges V{ T{ live-range f 0 10 } } }
}
! This guy will invoke the 'spill new' code path
T{ live-interval
{ vreg T{ vreg { n 5 } { reg-class int-regs } } }
{ start 2 }
{ end 8 }
{ uses V{ 8 } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
H{ { int-regs { "A" } } }
check-linear-scan
] unit-test
SYMBOL: available SYMBOL: available
SYMBOL: taken SYMBOL: taken

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

@ -13,7 +13,6 @@ C: <live-range> live-range
TUPLE: live-interval TUPLE: live-interval
vreg vreg
reg spill-to reload-from reg spill-to reload-from
split-before split-after split-next
start end ranges uses start end ranges uses
copy-from ; copy-from ;

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

@ -98,15 +98,18 @@ M: ##dispatch linearize-insn
M: ##gc linearize-insn M: ##gc linearize-insn
nip nip
[ temp1>> ] {
[ temp2>> ] [ temp1>> ]
[ [ temp2>> ]
live-values>> [
[ compute-gc-roots ] live-values>>
[ count-gc-roots ] [ compute-gc-roots ]
[ gc-roots-size ] [ count-gc-roots ]
tri [ gc-roots-size ]
] tri tri
]
[ uninitialized-locs>> ]
} cleave
_gc ; _gc ;
: linearize-basic-blocks ( cfg -- insns ) : linearize-basic-blocks ( cfg -- insns )

4
basis/compiler/cfg/liveness/ssa/ssa.factor
View File

@ -55,3 +55,7 @@ SYMBOL: work-list
H{ } clone live-outs set H{ } clone live-outs set
dup post-order add-to-work-list dup post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ; work-list get [ liveness-step ] slurp-deque ;
: live-in? ( vreg bb -- ? ) live-in key? ;
: live-out? ( vreg bb -- ? ) live-out key? ;

6
basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences math USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions arrays compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.rpo ; compiler.cfg.liveness.ssa compiler.cfg.rpo ;
IN: compiler.cfg.ssa.destruction.live-ranges IN: compiler.cfg.ssa.destruction.live-ranges
! Live ranges for interference testing ! Live ranges for interference testing
@ -52,9 +52,9 @@ PRIVATE>
ERROR: bad-kill-index vreg bb ; ERROR: bad-kill-index vreg bb ;
: kill-index ( vreg bb -- n ) : kill-index ( vreg bb -- n )
2dup live-out key? [ 2drop 1/0. ] [ 2dup live-out? [ 2drop 1/0. ] [
2dup kill-indices get at at* [ 2nip ] [ 2dup kill-indices get at at* [ 2nip ] [
drop 2dup live-in key? drop 2dup live-in?
[ bad-kill-index ] [ 2drop -1/0. ] if [ bad-kill-index ] [ 2drop -1/0. ] if
] if ] if
] if ; ] if ;

12
basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor
View File

@ -4,7 +4,7 @@ USING: accessors assocs fry kernel locals math math.order arrays
namespaces sequences sorting sets combinators combinators.short-circuit make namespaces sequences sorting sets combinators combinators.short-circuit make
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.liveness.ssa
compiler.cfg.dominance compiler.cfg.dominance
compiler.cfg.ssa.destruction.state compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest compiler.cfg.ssa.destruction.forest
@ -19,13 +19,13 @@ IN: compiler.cfg.ssa.destruction.process-blocks
SYMBOLS: phi-union unioned-blocks ; SYMBOLS: phi-union unioned-blocks ;
:: operand-live-into-phi-node's-block? ( bb src dst -- ? ) :: operand-live-into-phi-node's-block? ( bb src dst -- ? )
src bb live-in key? ; src bb live-in? ;
:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? ) :: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
dst src def-of live-out key? ; dst src def-of live-out? ;
:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? ) :: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
{ [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ; { [ src insn-of ##phi? ] [ src src def-of live-in? ] } 0&& ;
:: operand-being-renamed? ( bb src dst -- ? ) :: operand-being-renamed? ( bb src dst -- ? )
src processed-names get key? ; src processed-names get key? ;
@ -61,10 +61,10 @@ SYMBOLS: phi-union unioned-blocks ;
} cond ; } cond ;
: node-is-live-in-of-child? ( node child -- ? ) : node-is-live-in-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-in ] bi* key? ; [ vreg>> ] [ bb>> ] bi* live-in? ;
: node-is-live-out-of-child? ( node child -- ? ) : node-is-live-out-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-out ] bi* key? ; [ vreg>> ] [ bb>> ] bi* live-out? ;
:: insert-copy ( bb src dst -- ) :: insert-copy ( bb src dst -- )
bb src dst trivial-interference bb src dst trivial-interference

61
basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor Normal file
View File

@ -0,0 +1,61 @@
IN: compiler.cfg.stacks.uninitialized.tests
USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
namespaces accessors sequences ;
: test-uninitialized ( -- )
cfg new 0 get >>entry
compute-predecessors
compute-uninitialized-sets ;
V{
T{ ##inc-d f 3 }
} 0 test-bb
V{
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 0 D 2 }
T{ ##inc-r f 1 }
} 1 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##inc-d f 1 }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
[ ] [ test-uninitialized ] unit-test
[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
! When merging, if a location is uninitialized in one branch and
! initialized in another, we have to consider it uninitialized,
! since it cannot be safely read from by a ##peek, or traced by GC.
V{ } 0 test-bb
V{
T{ ##inc-d f 1 }
} 1 test-bb
V{
T{ ##call f namestack }
T{ ##branch }
} 2 test-bb
V{
T{ ##return }
} 3 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
[ ] [ test-uninitialized ] unit-test
[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test

76
basis/compiler/cfg/stacks/uninitialized/uninitialized.factor Normal file
View File

@ -0,0 +1,76 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences byte-arrays namespaces accessors classes math
math.order fry arrays combinators compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.dataflow-analysis ;
IN: compiler.cfg.stacks.uninitialized
! Uninitialized stack location analysis.
! Consider the following sequence of instructions:
! ##inc-d 2
! _gc
! ##replace ... D 0
! ##replace ... D 1
! The GC check runs before stack locations 0 and 1 have been initialized,
! and it needs to zero them out so that GC doesn't try to trace them.
<PRIVATE
GENERIC: visit-insn ( insn -- )
: handle-inc ( n symbol -- )
[
swap {
{ [ dup 0 < ] [ neg short tail ] }
{ [ dup 0 > ] [ <byte-array> prepend ] }
} cond
] change ;
M: ##inc-d visit-insn n>> ds-loc handle-inc ;
M: ##inc-r visit-insn n>> rs-loc handle-inc ;
ERROR: uninitialized-peek insn ;
M: ##peek visit-insn
dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
[ uninitialized-peek ] [ drop ] if ;
M: ##replace visit-insn
loc>> [ n>> ] [ class get ] bi
2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
M: insn visit-insn drop ;
: prepare ( pair -- )
[ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if*
[ ds-loc set ] [ rs-loc set ] bi* ;
: visit-block ( bb -- ) instructions>> [ visit-insn ] each ;
: finish ( -- pair ) ds-loc get rs-loc get 2array ;
: (join-sets) ( seq1 seq2 -- seq )
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
[ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
PRIVATE>
FORWARD-ANALYSIS: uninitialized
M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
drop [ prepare ] dip visit-block finish ;
M: uninitialized-analysis join-sets ( sets analysis -- pair )
drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
: uninitialized-locs ( bb -- locs )
uninitialized-in dup [
first2
[ [ <ds-loc> ] (uninitialized-locs) ]
[ [ <rs-loc> ] (uninitialized-locs) ]
bi* append
] when ;

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

@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes continuations.private fry cpu.architecture classes locals
source-files.errors source-files.errors
compiler.errors compiler.errors
compiler.alien compiler.alien
@ -215,13 +215,44 @@ M: ##write-barrier generate-insn
[ table>> ] [ table>> ]
tri %write-barrier ; tri %write-barrier ;
! GC checks
: wipe-locs ( locs temp -- )
'[
_
[ 0 %load-immediate ]
[ swap [ %replace ] with each ] bi
] unless-empty ;
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
temp operand n>> %reload-integer
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
: 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 operand temp -- )
gc-root temp %load-gc-root
temp operand n>> %spill-integer ;
M: object load-gc-root drop %load-gc-root ;
: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
M: _gc generate-insn M: _gc generate-insn
"no-gc" define-label
{ {
[ temp1>> ] [ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
[ temp2>> ] [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
[ gc-roots>> ] [ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
[ gc-root-count>> ] [ gc-root-count>> %call-gc ]
} cleave %gc ; [ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
} cleave
"no-gc" resolve-label ;
M: _loop-entry generate-insn drop %loop-entry ; M: _loop-entry generate-insn drop %loop-entry ;

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

@ -128,7 +128,12 @@ HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %allot cpu ( dst size class temp -- ) HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- ) HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
! GC checks
HOOK: %check-nursery cpu ( label temp1 temp2 -- )
HOOK: %save-gc-root cpu ( gc-root register -- )
HOOK: %load-gc-root cpu ( gc-root register -- )
HOOK: %call-gc cpu ( gc-root-count -- )
HOOK: %prologue cpu ( n -- ) HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- ) HOOK: %epilogue cpu ( n -- )

144
basis/cpu/ppc/ppc.factor
View File

@ -76,8 +76,12 @@ HOOK: reserved-area-size os ( -- n )
: xt-save ( n -- i ) 2 cells - ; : xt-save ( n -- i ) 2 cells - ;
! Next, we have the spill area as well as the FFI parameter area. ! Next, we have the spill area as well as the FFI parameter area.
! They overlap, since basic blocks with FFI calls will never ! It is safe for them to overlap, since basic blocks with FFI calls
! spill. ! will never spill -- indeed, basic blocks with FFI calls do not
! use vregs at all, and the FFI call is a stack analysis sync point.
! In the future this will change and the stack frame logic will
! need to be untangled somewhat.
: param@ ( n -- x ) reserved-area-size + ; inline : param@ ( n -- x ) reserved-area-size + ; inline
: param-save-size ( -- n ) 8 cells ; foldable : param-save-size ( -- n ) 8 cells ; foldable
@ -85,32 +89,30 @@ HOOK: reserved-area-size os ( -- n )
: local@ ( n -- x ) : local@ ( n -- x )
reserved-area-size param-save-size + + ; inline reserved-area-size param-save-size + + ; inline
: spill-integer-base ( -- n )
stack-frame get spill-counts>> double-float-regs swap at
double-float-regs reg-size * ;
: spill-integer@ ( n -- offset ) : spill-integer@ ( n -- offset )
cells spill-integer-base + param@ ; spill-integer-offset param@ ;
: spill-float@ ( n -- offset ) : spill-float@ ( n -- offset )
double-float-regs reg-size * param@ ; spill-float-offset param@ ;
! Some FP intrinsics need a temporary scratch area in the stack ! Some FP intrinsics need a temporary scratch area in the stack
! frame, 8 bytes in size ! frame, 8 bytes in size. This is in the param-save area so it
! should not overlap with spill slots.
: scratch@ ( n -- offset ) : scratch@ ( n -- offset )
stack-frame get total-size>> stack-frame get total-size>>
factor-area-size - factor-area-size -
param-save-size - param-save-size -
+ ; + ;
! GC root area
: gc-root@ ( n -- offset )
gc-root-offset param@ ;
! Finally we have the linkage area ! Finally we have the linkage area
HOOK: lr-save os ( -- n ) HOOK: lr-save os ( -- n )
M: ppc stack-frame-size ( stack-frame -- i ) M: ppc stack-frame-size ( stack-frame -- i )
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ] (stack-frame-size)
[ params>> ]
[ return>> ]
tri + +
param-save-size + param-save-size +
reserved-area-size + reserved-area-size +
factor-area-size + factor-area-size +
@ -176,95 +178,28 @@ M: ppc %or OR ;
M: ppc %or-imm ORI ; M: ppc %or-imm ORI ;
M: ppc %xor XOR ; M: ppc %xor XOR ;
M: ppc %xor-imm XORI ; M: ppc %xor-imm XORI ;
M: ppc %shl SLW ;
M: ppc %shl-imm swapd SLWI ; M: ppc %shl-imm swapd SLWI ;
M: ppc %shr-imm SRW ;
M: ppc %shr-imm swapd SRWI ; M: ppc %shr-imm swapd SRWI ;
M: ppc %sar SRAW ;
M: ppc %sar-imm SRAWI ; M: ppc %sar-imm SRAWI ;
M: ppc %not NOT ; M: ppc %not NOT ;
: %alien-invoke-tail ( func dll -- ) :: overflow-template ( label dst src1 src2 insn -- )
[ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
:: exchange-regs ( r1 r2 -- )
scratch-reg r1 MR
r1 r2 MR
r2 scratch-reg MR ;
: ?MR ( r1 r2 -- ) 2dup = [ 2drop ] [ MR ] if ;
:: move>args ( src1 src2 -- )
{
{ [ src1 4 = ] [ 3 src2 ?MR 3 4 exchange-regs ] }
{ [ src1 3 = ] [ 4 src2 ?MR ] }
{ [ src2 3 = ] [ 4 src1 ?MR 3 4 exchange-regs ] }
{ [ src2 4 = ] [ 3 src1 ?MR ] }
[ 3 src1 MR 4 src2 MR ]
} cond ;
: clear-xer ( -- )
0 0 LI 0 0 LI
0 MTXER ; inline 0 MTXER
dst src2 src1 insn call
label BNO ; inline
:: overflow-template ( src1 src2 insn func -- ) M: ppc %fixnum-add ( label dst src1 src2 -- )
"no-overflow" define-label [ ADDO. ] overflow-template ;
clear-xer
scratch-reg src2 src1 insn call
scratch-reg ds-reg 0 STW
"no-overflow" get BNO
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
:: overflow-template-tail ( src1 src2 insn func -- ) M: ppc %fixnum-sub ( label dst src1 src2 -- )
"overflow" define-label [ SUBFO. ] overflow-template ;
clear-xer
scratch-reg src2 src1 insn call
"overflow" get BO
scratch-reg ds-reg 0 STW
BLR
"overflow" resolve-label
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke-tail ; inline
M: ppc %fixnum-add ( src1 src2 -- ) M:: ppc %fixnum-mul ( label dst src1 src2 -- )
[ ADDO. ] "overflow_fixnum_add" overflow-template ; [ MULLWO. ] overflow-template ;
M: ppc %fixnum-add-tail ( src1 src2 -- )
[ ADDO. ] "overflow_fixnum_add" overflow-template-tail ;
M: ppc %fixnum-sub ( src1 src2 -- )
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template ;
M: ppc %fixnum-sub-tail ( src1 src2 -- )
[ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
temp2 ds-reg 0 STW
"no-overflow" get BNO
src2 src2 tag-bits get SRAWI
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
clear-xer
temp1 src1 tag-bits get SRAWI
temp2 temp1 src2 MULLWO.
"overflow" get BO
temp2 ds-reg 0 STW
BLR
"overflow" resolve-label
src2 src2 tag-bits get SRAWI
temp1 src2 move>args
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline : bignum@ ( n -- offset ) cells bignum tag-number - ; inline
@ -462,17 +397,26 @@ M:: ppc %write-barrier ( src card# table -- )
src card# deck-bits SRWI src card# deck-bits SRWI
table scratch-reg card# STBX ; table scratch-reg card# STBX ;
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- ) M:: ppc %check-nursery ( label temp1 temp2 -- )
"end" define-label
temp2 load-zone-ptr temp2 load-zone-ptr
temp1 temp2 cell LWZ temp1 temp2 cell LWZ
temp2 temp2 3 cells LWZ temp2 temp2 3 cells LWZ
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here ! add ALLOT_BUFFER_ZONE to here
temp1 0 temp2 CMP ! is here >= end? temp1 temp1 1024 ADDI
"end" get BLE ! is here >= end?
temp1 0 temp2 CMP
label BLE ;
M:: ppc %save-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ STW ;
M:: ppc %load-gc-root ( gc-root register -- )
register 1 gc-root gc-root@ LWZ ;
M:: ppc %call-gc ( gc-root-count -- )
%prepare-alien-invoke %prepare-alien-invoke
0 3 LI 3 1 gc-root-base param@ ADDI
0 4 LI gc-root-count 4 LI
"inline_gc" f %alien-invoke "inline_gc" f %alien-invoke
"end" resolve-label ; "end" resolve-label ;

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

@ -1,13 +1,12 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: locals alien.c-types alien.syntax arrays kernel fry USING: locals alien.c-types alien.syntax arrays kernel fry math
math namespaces sequences system layouts io vocabs.loader namespaces sequences system layouts io vocabs.loader accessors init
accessors init combinators command-line cpu.x86.assembler combinators command-line make compiler compiler.units
cpu.x86 cpu.architecture make compiler compiler.units
compiler.constants compiler.alien compiler.codegen compiler.constants compiler.alien compiler.codegen
compiler.codegen.fixup compiler.cfg.instructions compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler
compiler.cfg.stack-frame ; cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
IN: cpu.x86.32 IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once. ! We implement the FFI for Linux, OS X and Windows all at once.

3
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ; cpu.x86.assembler cpu.x86.assembler.operands layouts
vocabs parser compiler.constants ;
IN: bootstrap.x86 IN: bootstrap.x86
4 \ cell set 4 \ cell set

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

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

3
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ; layouts vocabs parser compiler.constants math
cpu.x86.assembler cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
8 \ cell set 8 \ cell set

2
basis/cpu/x86/64/unix/bootstrap.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ; cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ;
IN: bootstrap.x86 IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ; : stack-frame-size ( -- n ) 4 bootstrap-cells ;

8
basis/cpu/x86/64/unix/unix.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences math splitting make assocs USING: accessors arrays sequences math splitting make assocs kernel
kernel layouts system alien.c-types alien.structs layouts system alien.c-types alien.structs cpu.architecture
cpu.architecture cpu.x86.assembler cpu.x86 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
compiler.codegen compiler.cfg.registers ; compiler.cfg.registers ;
IN: cpu.x86.64.unix IN: cpu.x86.64.unix
M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ; M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;

3
basis/cpu/x86/64/winnt/bootstrap.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser ; layouts vocabs parser cpu.x86.assembler
cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ; : stack-frame-size ( -- n ) 8 bootstrap-cells ;

6
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -1,6 +1,9 @@
USING: cpu.x86.assembler kernel tools.test namespaces make ; USING: cpu.x86.assembler cpu.x86.assembler.operands
kernel tools.test namespaces make ;
IN: cpu.x86.assembler.tests IN: cpu.x86.assembler.tests
[ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
@ -68,6 +71,7 @@ IN: cpu.x86.assembler.tests
! sse shift instructions ! sse shift instructions
[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test [ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: d1 HEX: c1 } ] [ [ XMM0 XMM1 PSRLW ] { } make ] unit-test
! sse comparison instructions ! sse comparison instructions
[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test [ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test

210
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,90 +1,15 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays io.binary kernel combinators kernel.private math USING: arrays io.binary kernel combinators kernel.private math locals
namespaces make sequences words system layouts math.order accessors namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ; cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
QUALIFIED: sequences QUALIFIED: sequences
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64. ! A postfix assembler for x86-32 and x86-64.
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
TUPLE: byte value ;
C: <byte> byte
<PRIVATE <PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
: reg-code ( reg -- n ) "register" word-prop 7 bitand ; : reg-code ( reg -- n ) "register" word-prop 7 bitand ;
: indirect-base* ( op -- n ) base>> EBP or reg-code ; : indirect-base* ( op -- n ) base>> EBP or reg-code ;
@ -159,27 +84,13 @@ M: indirect displacement,
dup displacement>> dup [ dup displacement>> dup [
swap base>> swap base>>
[ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
] [ ] [ 2drop ] if ;
2drop
] if ;
M: register displacement, drop ; M: register displacement, drop ;
: addressing ( reg# indirect -- ) : addressing ( reg# indirect -- )
[ mod-r/m, ] [ sib, ] [ displacement, ] tri ; [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
! Utilities
UNION: operand register indirect ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
: rex.w? ( rex.w reg r/m -- ? ) : rex.w? ( rex.w reg r/m -- ? )
{ {
{ [ dup register-128? ] [ drop operand-64? ] } { [ dup register-128? ] [ drop operand-64? ] }
@ -192,22 +103,25 @@ M: object operand-64? drop f ;
: rex.b ( m op -- n ) : rex.b ( m op -- n )
[ extended? [ BIN: 00000001 bitor ] when ] keep [ extended? [ BIN: 00000001 bitor ] when ] keep
dup indirect? [ dup indirect? [ index>> extended? [ BIN: 00000010 bitor ] when ] [ drop ] if ;
index>> extended? [ BIN: 00000010 bitor ] when
] [
drop
] if ;
: rex-prefix ( reg r/m rex.w -- ) : no-prefix? ( prefix reg r/m -- ? )
[ BIN: 01000000 = ]
[ extended-8-bit-register? not ]
[ extended-8-bit-register? not ] tri*
and and ;
:: rex-prefix ( reg r/m rex.w -- )
#! Compile an AMD64 REX prefix. #! Compile an AMD64 REX prefix.
2over rex.w? BIN: 01001000 BIN: 01000000 ? rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
swap rex.r swap rex.b r/m rex.r
dup BIN: 01000000 = [ drop ] [ , ] if ; reg rex.b
dup reg r/m no-prefix? [ drop ] [ , ] if ;
: 16-prefix ( reg r/m -- ) : 16-prefix ( reg r/m -- )
[ register-16? ] either? [ HEX: 66 , ] when ; [ register-16? ] either? [ HEX: 66 , ] when ;
: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ; : prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
: prefix-1 ( reg rex.w -- ) f swap prefix ; : prefix-1 ( reg rex.w -- ) f swap prefix ;
@ -269,22 +183,10 @@ M: object operand-64? drop f ;
: 2-operand ( dst src op -- ) : 2-operand ( dst src op -- )
#! Sets the opcode's direction bit. It is set if the #! Sets the opcode's direction bit. It is set if the
#! destination is a direct register operand. #! destination is a direct register operand.
2over 16-prefix [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
direction-bit
operand-size-bit
(2-operand) ;
PRIVATE> PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;
! Moving stuff ! Moving stuff
GENERIC: PUSH ( op -- ) GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ; M: register PUSH f HEX: 50 short-operand ;
@ -681,24 +583,57 @@ ALIAS: PINSRQ PINSRD
: MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ; : MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ;
: MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ; : MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ;
: MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ; : MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ;
: PUNPCKLBW ( dest src -- ) HEX: 60 HEX: 66 2-operand-rm-sse ;
: PUNPCKLWD ( dest src -- ) HEX: 61 HEX: 66 2-operand-rm-sse ;
: PUNPCKLDQ ( dest src -- ) HEX: 62 HEX: 66 2-operand-rm-sse ;
: PACKSSWB ( dest src -- ) HEX: 63 HEX: 66 2-operand-rm-sse ;
: PCMPGTB ( dest src -- ) HEX: 64 HEX: 66 2-operand-rm-sse ;
: PCMPGTW ( dest src -- ) HEX: 65 HEX: 66 2-operand-rm-sse ;
: PCMPGTD ( dest src -- ) HEX: 66 HEX: 66 2-operand-rm-sse ;
: PACKUSWB ( dest src -- ) HEX: 67 HEX: 66 2-operand-rm-sse ;
: PUNPCKHBW ( dest src -- ) HEX: 68 HEX: 66 2-operand-rm-sse ;
: PUNPCKHWD ( dest src -- ) HEX: 69 HEX: 66 2-operand-rm-sse ;
: PUNPCKHDQ ( dest src -- ) HEX: 6a HEX: 66 2-operand-rm-sse ;
: PACKSSDW ( dest src -- ) HEX: 6b HEX: 66 2-operand-rm-sse ;
: PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ; : PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ;
: PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ; : PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ;
: MOVD ( dest src -- ) { HEX: 6e HEX: 7e } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; : MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; : MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ; : PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; : PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; : PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; : (PSRLW-imm) ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; : (PSRAW-imm) ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ; : (PSLLW-imm) ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ; : (PSRLD-imm) ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ; : (PSRAD-imm) ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ; : (PSLLD-imm) ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
: (PSRLQ-imm) ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
: (PSLLQ-imm) ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
: (PSRLW-reg) ( dest src -- ) HEX: d1 HEX: 66 2-operand-rm-sse ;
: (PSRLD-reg) ( dest src -- ) HEX: d2 HEX: 66 2-operand-rm-sse ;
: (PSRLQ-reg) ( dest src -- ) HEX: d3 HEX: 66 2-operand-rm-sse ;
: (PSRAW-reg) ( dest src -- ) HEX: e1 HEX: 66 2-operand-rm-sse ;
: (PSRAD-reg) ( dest src -- ) HEX: e2 HEX: 66 2-operand-rm-sse ;
: (PSLLW-reg) ( dest src -- ) HEX: f1 HEX: 66 2-operand-rm-sse ;
: (PSLLD-reg) ( dest src -- ) HEX: f2 HEX: 66 2-operand-rm-sse ;
: (PSLLQ-reg) ( dest src -- ) HEX: f3 HEX: 66 2-operand-rm-sse ;
: PSRLW ( dest src -- ) dup integer? [ (PSRLW-imm) ] [ (PSRLW-reg) ] if ;
: PSRAW ( dest src -- ) dup integer? [ (PSRAW-imm) ] [ (PSRAW-reg) ] if ;
: PSLLW ( dest src -- ) dup integer? [ (PSLLW-imm) ] [ (PSLLW-reg) ] if ;
: PSRLD ( dest src -- ) dup integer? [ (PSRLD-imm) ] [ (PSRLD-reg) ] if ;
: PSRAD ( dest src -- ) dup integer? [ (PSRAD-imm) ] [ (PSRAD-reg) ] if ;
: PSLLD ( dest src -- ) dup integer? [ (PSLLD-imm) ] [ (PSLLD-reg) ] if ;
: PSRLQ ( dest src -- ) dup integer? [ (PSRLQ-imm) ] [ (PSRLQ-reg) ] if ;
: PSLLQ ( dest src -- ) dup integer? [ (PSLLQ-imm) ] [ (PSLLQ-reg) ] if ;
: PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ; : PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ;
: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
: PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ; : PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ;
: PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ; : PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ;
@ -709,11 +644,14 @@ ALIAS: PINSRQ PINSRD
: HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ; : HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ;
: HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ; : HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ;
: FXSAVE ( dest -- ) { BIN: 000 f { HEX: 0f HEX: ae } } 1-operand ;
: FXRSTOR ( src -- ) { BIN: 001 f { HEX: 0f HEX: ae } } 1-operand ;
: LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ; : LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ;
: STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ; : STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ;
: LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ; : LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ;
: MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ; : MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ;
: SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ; : SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ;
: CLFLUSH ( dest -- ) { BIN: 111 f { HEX: 0f HEX: ae } } 1-operand ;
: POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ; : POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ;
@ -762,26 +700,46 @@ ALIAS: PINSRQ PINSRD
: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; : ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; : ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
: PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ; : PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ;
: PMULLW ( dest src -- ) HEX: d5 HEX: 66 2-operand-rm-sse ;
: PMOVMSKB ( dest src -- ) HEX: d7 HEX: 66 2-operand-rm-sse ;
: PSUBUSB ( dest src -- ) HEX: d8 HEX: 66 2-operand-rm-sse ;
: PSUBUSW ( dest src -- ) HEX: d9 HEX: 66 2-operand-rm-sse ;
: PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ; : PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ;
: PAND ( dest src -- ) HEX: db HEX: 66 2-operand-rm-sse ;
: PADDUSB ( dest src -- ) HEX: dc HEX: 66 2-operand-rm-sse ;
: PADDUSW ( dest src -- ) HEX: dd HEX: 66 2-operand-rm-sse ;
: PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ; : PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ;
: PANDN ( dest src -- ) HEX: df HEX: 66 2-operand-rm-sse ;
: PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ; : PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ;
: PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ; : PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ;
: PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ; : PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ;
: PMULHW ( dest src -- ) HEX: e5 HEX: 66 2-operand-rm-sse ;
: CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ; : CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ;
: CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ; : CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ;
: CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ; : CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ;
: MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ; : MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ;
: PSUBSB ( dest src -- ) HEX: e8 HEX: 66 2-operand-rm-sse ;
: PSUBSW ( dest src -- ) HEX: e9 HEX: 66 2-operand-rm-sse ;
: PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ; : PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ;
: POR ( dest src -- ) HEX: eb HEX: 66 2-operand-rm-sse ;
: PADDSB ( dest src -- ) HEX: ec HEX: 66 2-operand-rm-sse ;
: PADDSW ( dest src -- ) HEX: ed HEX: 66 2-operand-rm-sse ;
: PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ; : PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ;
: PXOR ( dest src -- ) HEX: ef HEX: 66 2-operand-rm-sse ;
: LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ; : LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ;
: PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ; : PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ;
: PMADDWD ( dest src -- ) HEX: f5 HEX: 66 2-operand-rm-sse ;
: PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ; : PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ;
: MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ; : MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ;
: PSUBB ( dest src -- ) HEX: f8 HEX: 66 2-operand-rm-sse ;
: PSUBW ( dest src -- ) HEX: f9 HEX: 66 2-operand-rm-sse ;
: PSUBD ( dest src -- ) HEX: fa HEX: 66 2-operand-rm-sse ;
: PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ; : PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ;
: PADDB ( dest src -- ) HEX: fc HEX: 66 2-operand-rm-sse ;
: PADDW ( dest src -- ) HEX: fd HEX: 66 2-operand-rm-sse ;
: PADDD ( dest src -- ) HEX: fe HEX: 66 2-operand-rm-sse ;
! x86-64 branch prediction hints ! x86-64 branch prediction hints

1
basis/cpu/x86/assembler/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov Slava Pestov
Joe Groff

118
basis/cpu/x86/assembler/operands/operands.factor Normal file
View File

@ -0,0 +1,118 @@
! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words math accessors sequences namespaces
assocs layouts cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler.operands
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
<PRIVATE
GENERIC: extended? ( op -- ? )
M: object extended? drop f ;
PREDICATE: register < word
"register" word-prop ;
PREDICATE: register-8 < register
"register-size" word-prop 8 = ;
PREDICATE: register-16 < register
"register-size" word-prop 16 = ;
PREDICATE: register-32 < register
"register-size" word-prop 32 = ;
PREDICATE: register-64 < register
"register-size" word-prop 64 = ;
PREDICATE: register-128 < register
"register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
! Utilities
UNION: operand register indirect ;
GENERIC: operand-64? ( operand -- ? )
M: indirect operand-64?
[ base>> ] [ index>> ] bi [ operand-64? ] either? ;
M: register-64 operand-64? drop t ;
M: object operand-64? drop f ;
PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;
TUPLE: byte value ;
C: <byte> byte
: extended-8-bit-register? ( register -- ? )
{ SPL BPL SIL DIL } memq? ;
: n-bit-version-of ( register n -- register' )
! Certain 8-bit registers don't exist in 32-bit mode...
[ "register" word-prop ] dip registers get at nth
dup extended-8-bit-register? cell 4 = and
[ drop f ] when ;
: 8-bit-version-of ( register -- register' ) 8 n-bit-version-of ;
: 16-bit-version-of ( register -- register' ) 16 n-bit-version-of ;
: 32-bit-version-of ( register -- register' ) 32 n-bit-version-of ;
: 64-bit-version-of ( register -- register' ) 64 n-bit-version-of ;
: native-version-of ( register -- register' ) cell-bits n-bit-version-of ;

27
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -1,14 +1,23 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel words words.symbol sequences lexer parser fry ; USING: kernel words words.symbol sequences lexer parser fry
namespaces combinators assocs ;
IN: cpu.x86.assembler.syntax IN: cpu.x86.assembler.syntax
: define-register ( name num size -- ) SYMBOL: registers
[ "cpu.x86.assembler" create dup define-symbol ] 2dip
[ dupd "register" set-word-prop ] dip
"register-size" set-word-prop ;
: define-registers ( names size -- ) registers [ H{ } clone ] initialize
'[ _ define-register ] each-index ;
SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ; : define-register ( name num size -- word )
[ "cpu.x86.assembler.operands" create ] 2dip {
[ 2drop ]
[ 2drop define-symbol ]
[ drop "register" set-word-prop ]
[ nip "register-size" set-word-prop ]
} 3cleave ;
: define-registers ( size names -- )
[ swap '[ _ define-register ] map-index ] [ drop ] 2bi
registers get set-at ;
SYNTAX: REGISTERS: scan-word ";" parse-tokens define-registers ;

8
basis/cpu/x86/bootstrap.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces USING: bootstrap.image.private kernel kernel.private namespaces system
system cpu.x86.assembler layouts compiler.units math layouts compiler.units math math.private compiler.constants vocabs
math.private compiler.constants vocabs slots.private words slots.private words locals.backend make sequences combinators arrays
locals.backend make sequences combinators arrays ; cpu.x86.assembler cpu.x86.assembler.operands ;
IN: bootstrap.x86 IN: bootstrap.x86
big-endian off big-endian off

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

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
kernel kernel.private math memory namespaces make sequences cpu.architecture kernel kernel.private math memory namespaces make
words system layouts combinators math.order fry locals sequences words system layouts combinators math.order fry locals
compiler.constants compiler.constants
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
@ -264,93 +264,118 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
: small-reg-8 ( reg -- reg' ) ! The 'small-reg' mess is pretty crappy, but its only used on x86-32.
H{ ! On x86-64, all registers have 8-bit versions. However, a similar
{ EAX RAX } ! problem arises for shifts, where the shift count must be in CL, and
{ ECX RCX } ! so one day I will fix this properly by adding precoloring to the
{ EDX RDX } ! register allocator.
{ EBX RBX }
{ ESP RSP }
{ EBP RBP }
{ ESI RSP }
{ EDI RDI }
{ RAX RAX } HOOK: has-small-reg? cpu ( reg size -- ? )
{ RCX RCX }
{ RDX RDX }
{ RBX RBX }
{ RSP RSP }
{ RBP RBP }
{ RSI RSP }
{ RDI RDI }
} at ; inline
: small-reg-4 ( reg -- reg' ) CONSTANT: have-byte-regs { EAX ECX EDX EBX }
small-reg-8 H{
{ RAX EAX }
{ RCX ECX }
{ RDX EDX }
{ RBX EBX }
{ RSP ESP }
{ RBP EBP }
{ RSI ESP }
{ RDI EDI }
} at ; inline
: small-reg-2 ( reg -- reg' ) M: x86.32 has-small-reg?
small-reg-4 H{
{ EAX AX }
{ ECX CX }
{ EDX DX }
{ EBX BX }
{ ESP SP }
{ EBP BP }
{ ESI SI }
{ EDI DI }
} at ; inline
: small-reg-1 ( reg -- reg' )
small-reg-4 {
{ EAX AL }
{ ECX CL }
{ EDX DL }
{ EBX BL }
} at ; inline
: small-reg ( reg size -- reg' )
{ {
{ 1 [ small-reg-1 ] } { 8 [ have-byte-regs memq? ] }
{ 2 [ small-reg-2 ] } { 16 [ drop t ] }
{ 4 [ small-reg-4 ] } { 32 [ drop t ] }
{ 8 [ small-reg-8 ] }
} case ; } case ;
HOOK: small-regs cpu ( -- regs ) M: x86.64 has-small-reg? 2drop t ;
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-reg-that-isn't ( exclude -- reg' )
small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ; [ have-byte-regs ] dip
[ native-version-of ] map
'[ _ memq? not ] find nip ;
: with-save/restore ( reg quot -- ) : with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
:: with-small-register ( dst exclude quot: ( new-dst -- ) -- ) :: with-small-register ( dst exclude size quot: ( new-dst -- ) -- )
#! If the destination register overlaps a small register, we ! If the destination register overlaps a small register with
#! call the quot with that. Otherwise, we find a small ! 'size' bits, we call the quot with that. Otherwise, we find a
#! register that is not in exclude, and call quot, saving ! small register that is not in exclude, and call quot, saving and
#! and restoring the small register. ! restoring the small register.
dst small-reg-native small-regs memq? [ dst quot call ] [ dst size has-small-reg? [ dst quot call ] [
exclude small-reg-that-isn't exclude small-reg-that-isn't
[ quot call ] with-save/restore [ quot call ] with-save/restore
] if ; inline ] if ; inline
M:: x86 %string-nth ( dst src index temp -- )
! We request a small-reg of size 8 since those of size 16 are
! a superset.
"end" define-label
dst { src index temp } 8 [| new-dst |
! Load the least significant 7 bits into new-dst.
! 8th bit indicates whether we have to load from
! the aux vector or not.
temp src index [+] LEA
new-dst 8-bit-version-of temp string-offset [+] MOV
new-dst new-dst 8-bit-version-of MOVZX
! Do we have to look at the aux vector?
new-dst HEX: 80 CMP
"end" get JL
! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
new-dst temp XCHG
! Compute index
new-dst index ADD
new-dst index ADD
! Load high 16 bits
new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
new-dst new-dst 16-bit-version-of MOVZX
new-dst 7 SHL
! Compute code point
new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } 8 [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 8-bit-version-of MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } size [| new-dst |
new-dst dup size n-bit-version-of dup src [] MOV
quot call
dst new-dst ?MOV
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
: %alien-signed-getter ( dst src size -- )
[ MOVSX ] %alien-integer-getter ; inline
M: x86 %alien-signed-1 8 %alien-signed-getter ;
M: x86 %alien-signed-2 16 %alien-signed-getter ;
M: x86 %alien-signed-4 32 %alien-signed-getter ;
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
M: x86 %alien-double [] MOVSD ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
new-value value ?MOV
ptr [] new-value size n-bit-version-of MOV
] with-small-register ; inline
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ; : shift-count? ( reg -- ? ) { ECX RCX } memq? ;
:: emit-shift ( dst src1 src2 quot -- ) :: emit-shift ( dst src1 src2 quot -- )
@ -362,7 +387,7 @@ M: x86.64 small-reg-native small-reg-8 ;
src2 CL quot call src2 CL quot call
dst src2 XCHG dst src2 XCHG
] [ ] [
ECX small-reg-native [ ECX native-version-of [
CL src2 MOV CL src2 MOV
drop dst CL quot call drop dst CL quot call
] with-save/restore ] with-save/restore
@ -373,80 +398,6 @@ M: x86 %shl [ SHL ] emit-shift ;
M: x86 %shr [ SHR ] emit-shift ; M: x86 %shr [ SHR ] emit-shift ;
M: x86 %sar [ SAR ] emit-shift ; M: x86 %sar [ SAR ] emit-shift ;
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
! Load the least significant 7 bits into new-dst.
! 8th bit indicates whether we have to load from
! the aux vector or not.
temp src index [+] LEA
new-dst 1 small-reg temp string-offset [+] MOV
new-dst new-dst 1 small-reg MOVZX
! Do we have to look at the aux vector?
new-dst HEX: 80 CMP
"end" get JL
! Yes, this is a non-ASCII character. Load aux vector
temp src string-aux-offset [+] MOV
new-dst temp XCHG
! Compute index
new-dst index ADD
new-dst index ADD
! Load high 16 bits
new-dst 2 small-reg new-dst byte-array-offset [+] MOV
new-dst new-dst 2 small-reg MOVZX
new-dst 7 SHL
! Compute code point
new-dst temp XOR
"end" resolve-label
dst new-dst ?MOV
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
ch { index str temp } [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 1 small-reg MOV
] with-small-register ;
:: %alien-integer-getter ( dst src size quot -- )
dst { src } [| new-dst |
new-dst dup size small-reg dup src [] MOV
quot call
dst new-dst ?MOV
] with-small-register ; inline
: %alien-unsigned-getter ( dst src size -- )
[ MOVZX ] %alien-integer-getter ; inline
M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
: %alien-signed-getter ( dst src size -- )
[ MOVSX ] %alien-integer-getter ; inline
M: x86 %alien-signed-1 1 %alien-signed-getter ;
M: x86 %alien-signed-2 2 %alien-signed-getter ;
M: x86 %alien-signed-4 4 %alien-signed-getter ;
M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
M: x86 %alien-cell [] MOV ;
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
M: x86 %alien-double [] MOVSD ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } [| new-value |
new-value value ?MOV
ptr [] new-value size small-reg MOV
] with-small-register ; inline
M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
: load-zone-ptr ( reg -- ) : load-zone-ptr ( reg -- )
#! Load pointer to start of zone array #! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ; 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
@ -484,38 +435,19 @@ M:: x86 %write-barrier ( src card# table -- )
table table [] MOV table table [] MOV
table card# [+] card-mark <byte> MOV ; table card# [+] card-mark <byte> MOV ;
:: check-nursery ( temp1 temp2 -- ) M:: x86 %check-nursery ( label temp1 temp2 -- )
temp1 load-zone-ptr temp1 load-zone-ptr
temp2 temp1 cell [+] MOV temp2 temp1 cell [+] MOV
temp2 1024 ADD temp2 1024 ADD
temp1 temp1 3 cells [+] MOV temp1 temp1 3 cells [+] MOV
temp2 temp1 CMP ; temp2 temp1 CMP
label JLE ;
GENERIC# save-gc-root 1 ( gc-root operand temp -- ) M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
M:: spill-slot save-gc-root ( gc-root spill-slot temp -- ) M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
temp spill-slot n>> spill-integer@ MOV
gc-root gc-root@ temp MOV ;
M:: word save-gc-root ( gc-root register temp -- ) M:: x86 %call-gc ( gc-root-count -- )
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 ! Pass pointer to start of GC roots as first parameter
param-reg-1 gc-root-base param@ LEA param-reg-1 gc-root-base param@ LEA
! Pass number of roots as second parameter ! Pass number of roots as second parameter
@ -524,15 +456,6 @@ M:: word load-gc-root ( gc-root register temp -- )
%prepare-alien-invoke %prepare-alien-invoke
"inline_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 M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;

2
extra/benchmark/pidigits/pidigits.factor
View File

@ -54,6 +54,6 @@ IN: benchmark.pidigits
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ; [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
: pidigits-main ( -- ) : pidigits-main ( -- )
10000 pidigits ; 2000 pidigits ;
MAIN: pidigits-main MAIN: pidigits-main

2
extra/gpu/demos/bunny/sobel.f.glsl
View File

@ -37,7 +37,7 @@ border_factor(vec2 texcoord)
void void
main() main()
{ {
gl_FragColor = /*vec4(border_factor(texcoord));*/ mix( gl_FragColor = mix(
texture2D(color_texture, texcoord), texture2D(color_texture, texcoord),
line_color, line_color,
border_factor(texcoord) border_factor(texcoord)

4
extra/gpu/render/render.factor
View File

@ -8,7 +8,7 @@ gpu.textures gpu.textures.private half-floats images kernel
lexer locals math math.order math.parser namespaces opengl lexer locals math math.order math.parser namespaces opengl
opengl.gl parser quotations sequences slots sorting opengl.gl parser quotations sequences slots sorting
specialized-arrays.alien specialized-arrays.float specialized-arrays.int specialized-arrays.alien specialized-arrays.float specialized-arrays.int
specialized-arrays.uint strings tr ui.gadgets.worlds variants specialized-arrays.uint strings ui.gadgets.worlds variants
vocabs.parser words ; vocabs.parser words ;
IN: gpu.render IN: gpu.render
@ -338,8 +338,6 @@ DEFER: [bind-uniform-tuple]
texture-unit' texture-unit'
value>>-quot { value-cleave 2cleave } append ; value>>-quot { value-cleave 2cleave } append ;
TR: hyphens>underscores "-" "_" ;
:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot ) :: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
prefix uniform name>> append hyphens>underscores :> name prefix uniform name>> append hyphens>underscores :> name
uniform uniform-type>> :> type uniform uniform-type>> :> type

16
extra/gpu/shaders/shaders.factor
View File

@ -8,7 +8,7 @@ io.encodings.ascii io.files io.pathnames kernel lexer literals
locals math math.parser memoize multiline namespaces opengl locals math math.parser memoize multiline namespaces opengl
opengl.gl opengl.shaders parser quotations sequences opengl.gl opengl.shaders parser quotations sequences
specialized-arrays.alien specialized-arrays.int splitting specialized-arrays.alien specialized-arrays.int splitting
strings ui.gadgets.worlds variants vectors vocabs vocabs.loader strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader
vocabs.parser words words.constant ; vocabs.parser words words.constant ;
IN: gpu.shaders IN: gpu.shaders
@ -65,6 +65,8 @@ MEMO: output-index ( program-instance output-name -- index )
<PRIVATE <PRIVATE
TR: hyphens>underscores "-" "_" ;
: gl-vertex-type ( component-type -- gl-type ) : gl-vertex-type ( component-type -- gl-type )
{ {
{ ubyte-components [ GL_UNSIGNED_BYTE ] } { ubyte-components [ GL_UNSIGNED_BYTE ] }
@ -125,12 +127,12 @@ MEMO: output-index ( program-instance output-name -- index )
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ; } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot ) :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> :> name vertex-attribute name>> hyphens>underscores :> name
vertex-attribute component-type>> :> type vertex-attribute component-type>> :> type
type gl-vertex-type :> gl-type type gl-vertex-type :> gl-type
vertex-attribute dim>> :> dim vertex-attribute dim>> :> dim
vertex-attribute normalize?>> >c-bool :> normalize? vertex-attribute normalize?>> >c-bool :> normalize?
vertex-attribute vertex-attribute-size :> size vertex-attribute vertex-attribute-size :> size
stride offset size + stride offset size +
{ {

7
vm/debug.cpp
View File

@ -173,10 +173,15 @@ void print_stack_frame(stack_frame *frame)
print_string("\n"); print_string("\n");
print_obj(frame_scan(frame)); print_obj(frame_scan(frame));
print_string("\n"); print_string("\n");
print_string("word/quot addr: ");
print_cell_hex((cell)frame_executing(frame)); print_cell_hex((cell)frame_executing(frame));
print_string(" "); print_string("\n");
print_string("word/quot xt: ");
print_cell_hex((cell)frame->xt); print_cell_hex((cell)frame->xt);
print_string("\n"); print_string("\n");
print_string("return address: ");
print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame));
print_string("\n");
} }
void print_callstack() void print_callstack()