Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
0838beed1e
|
|
@ -55,10 +55,13 @@ For X11 support, you need recent development libraries for libc,
|
|||
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
|
||||
(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
|
||||
automatically:
|
||||
automatically when you run Factor:
|
||||
|
||||
./factor
|
||||
|
||||
|
|
|
|||
|
|
@ -29,5 +29,6 @@ M: library dispose dll>> [ dispose ] when* ;
|
|||
: remove-library ( name -- )
|
||||
libraries get delete-at* [ dispose ] [ drop ] if ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get [ delete-at ] [ set-at ] 2bi ;
|
||||
: add-library ( name path abi -- )
|
||||
[ 2drop remove-library ]
|
||||
[ <library> swap libraries get set-at ] 3bi ;
|
||||
|
|
@ -10,6 +10,10 @@ math.order quotations quotations.private assocs.private ;
|
|||
FROM: compiler => enable-optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
||||
"profile-compiler" get [
|
||||
"bootstrap.compiler.timing" require
|
||||
] when
|
||||
|
||||
! Don't bring this in when deploying, since it will store a
|
||||
! reference to 'eval' in a global variable
|
||||
"deploy-vocab" get "staging" get or [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,17 +1,27 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences assocs
|
||||
compiler.cfg.rpo compiler.cfg.instructions
|
||||
compiler.cfg.hats ;
|
||||
USING: accessors kernel sequences assocs fry
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.stacks.uninitialized ;
|
||||
IN: compiler.cfg.gc-checks
|
||||
|
||||
: gc? ( bb -- ? )
|
||||
: insert-gc-check? ( bb -- ? )
|
||||
instructions>> [ ##allocation? ] any? ;
|
||||
|
||||
: insert-gc-check ( basic-block -- )
|
||||
dup gc? [
|
||||
[ i i f \ ##gc new-insn prefix ] change-instructions drop
|
||||
] [ drop ] if ;
|
||||
: blocks-with-gc ( cfg -- bbs )
|
||||
post-order [ insert-gc-check? ] filter ;
|
||||
|
||||
: insert-gc-check ( bb -- )
|
||||
dup '[
|
||||
i i f _ uninitialized-locs \ ##gc new-insn
|
||||
prefix
|
||||
] change-instructions drop ;
|
||||
|
||||
: 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 ;
|
||||
|
|
@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
|
|||
INSN: ##fixnum-sub < ##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.
|
||||
INSN: _prologue stack-frame ;
|
||||
|
|
@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ;
|
|||
|
||||
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
|
||||
! virtual registers
|
||||
|
|
|
|||
|
|
@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
|
|||
slots.private:set-slot
|
||||
strings.private:string-nth
|
||||
strings.private:set-string-nth-fast
|
||||
! classes.tuple.private:<tuple-boa>
|
||||
! arrays:<array>
|
||||
! byte-arrays:<byte-array>
|
||||
! byte-arrays:(byte-array)
|
||||
! kernel:<wrapper>
|
||||
classes.tuple.private:<tuple-boa>
|
||||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
kernel:<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
alien.accessors:alien-signed-1
|
||||
|
|
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-unsigned-2
|
||||
alien.accessors:alien-signed-2
|
||||
alien.accessors:set-alien-signed-2
|
||||
! alien.accessors:alien-cell
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
|
||||
|
|
@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} drop f [ t "intrinsic" set-word-prop ] each ;
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
|
|
|||
|
|
@ -98,15 +98,18 @@ M: ##dispatch linearize-insn
|
|||
|
||||
M: ##gc linearize-insn
|
||||
nip
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[
|
||||
live-values>>
|
||||
[ compute-gc-roots ]
|
||||
[ count-gc-roots ]
|
||||
[ gc-roots-size ]
|
||||
tri
|
||||
] tri
|
||||
{
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[
|
||||
live-values>>
|
||||
[ compute-gc-roots ]
|
||||
[ count-gc-roots ]
|
||||
[ gc-roots-size ]
|
||||
tri
|
||||
]
|
||||
[ uninitialized-locs>> ]
|
||||
} cleave
|
||||
_gc ;
|
||||
|
||||
: linearize-basic-blocks ( cfg -- insns )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: compiler.cfg.liveness.ssa
|
|||
! TODO: merge with compiler.cfg.liveness
|
||||
|
||||
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
|
||||
! is in conrrespondence with a predecessor
|
||||
! is in correspondence with a predecessor
|
||||
SYMBOL: phi-live-ins
|
||||
|
||||
: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
|
||||
|
|
@ -31,7 +31,7 @@ SYMBOL: work-list
|
|||
: update-live-in ( basic-block -- changed? )
|
||||
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
|
||||
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
|
||||
bi and ;
|
||||
bi or ;
|
||||
|
||||
: compute-live-out ( basic-block -- live-out )
|
||||
[ successors>> [ live-in ] map ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs hashtables fry kernel make namespaces
|
||||
USING: accessors assocs hashtables fry kernel make namespaces sets
|
||||
sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
|
||||
IN: compiler.cfg.ssa.destruction.copies
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ ERROR: bad-copy ;
|
|||
: compute-copies ( assoc -- assoc' )
|
||||
dup assoc-size <hashtable> [
|
||||
'[
|
||||
[
|
||||
prune [
|
||||
2dup eq? [ 2drop ] [
|
||||
_ 2dup key?
|
||||
[ bad-copy ] [ set-at ] if
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ SYMBOL: seen
|
|||
|
||||
:: visit-renaming ( dst assoc src bb -- )
|
||||
src seen get key? [
|
||||
src dst bb waiting-for push-at
|
||||
src dst bb add-waiting
|
||||
src assoc delete-at
|
||||
] [ src seen get conjoin ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ SYMBOLS: phi-union unioned-blocks ;
|
|||
2nip processed-name ;
|
||||
|
||||
:: trivial-interference ( bb src dst -- )
|
||||
dst src bb waiting-for push-at
|
||||
dst src bb add-waiting
|
||||
src used-by-another get push ;
|
||||
|
||||
:: add-to-renaming-set ( bb src dst -- )
|
||||
|
|
|
|||
|
|
@ -14,3 +14,5 @@ SYMBOLS: processed-names waiting used-by-another renaming-sets ;
|
|||
: processed-name ( vreg -- ) processed-names get conjoin ;
|
||||
|
||||
: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
|
||||
|
||||
: add-waiting ( dst src bb -- ) waiting-for push-at ;
|
||||
|
|
@ -26,7 +26,7 @@ M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union
|
|||
! which are going to be overwritten.
|
||||
BACKWARD-ANALYSIS: kill
|
||||
|
||||
M: kill-analysis transfer-set drop replace-set assoc-union ;
|
||||
M: kill-analysis transfer-set drop kill-set assoc-union ;
|
||||
|
||||
! Main word
|
||||
: compute-global-sets ( cfg -- cfg' )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel math namespaces sets make sequences
|
||||
USING: accessors assocs kernel math math.order namespaces sets make
|
||||
sequences combinators fry
|
||||
compiler.cfg
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions
|
||||
|
|
@ -12,14 +13,18 @@ IN: compiler.cfg.stacks.local
|
|||
! Local stack analysis. We build local peek and replace sets for every basic
|
||||
! block while constructing the CFG.
|
||||
|
||||
SYMBOLS: peek-sets replace-sets ;
|
||||
SYMBOLS: peek-sets replace-sets kill-sets ;
|
||||
|
||||
SYMBOL: locs>vregs
|
||||
|
||||
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
|
||||
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
|
||||
|
||||
TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
|
||||
TUPLE: current-height
|
||||
{ d initial: 0 }
|
||||
{ r initial: 0 }
|
||||
{ emit-d initial: 0 }
|
||||
{ emit-r initial: 0 } ;
|
||||
|
||||
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
|
||||
|
||||
|
|
@ -72,20 +77,32 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
|
|||
bi
|
||||
] if ;
|
||||
|
||||
: compute-local-kill-set ( -- assoc )
|
||||
basic-block get current-height get
|
||||
[ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
|
||||
[ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
|
||||
[ drop local-replace-set get at ] 2tri
|
||||
[ append unique dup ] dip update ;
|
||||
|
||||
: begin-local-analysis ( -- )
|
||||
H{ } clone local-peek-set set
|
||||
H{ } clone local-replace-set set
|
||||
H{ } clone replace-mapping set
|
||||
current-height get 0 >>emit-d 0 >>emit-r drop
|
||||
current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
|
||||
current-height get
|
||||
[ 0 >>emit-d 0 >>emit-r drop ]
|
||||
[ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
|
||||
|
||||
: end-local-analysis ( -- )
|
||||
emit-changes
|
||||
local-peek-set get basic-block get peek-sets get set-at
|
||||
local-replace-set get basic-block get replace-sets get set-at ;
|
||||
basic-block get {
|
||||
[ [ local-peek-set get ] dip peek-sets get set-at ]
|
||||
[ [ local-replace-set get ] dip replace-sets get set-at ]
|
||||
[ [ compute-local-kill-set ] dip kill-sets get set-at ]
|
||||
} cleave ;
|
||||
|
||||
: clone-current-height ( -- )
|
||||
current-height [ clone ] change ;
|
||||
|
||||
: peek-set ( bb -- assoc ) peek-sets get at ;
|
||||
: replace-set ( bb -- assoc ) replace-sets get at ;
|
||||
: kill-set ( bb -- assoc ) kill-sets get at ;
|
||||
|
|
@ -13,6 +13,7 @@ IN: compiler.cfg.stacks
|
|||
H{ } clone rs-heights set
|
||||
H{ } clone peek-sets set
|
||||
H{ } clone replace-sets set
|
||||
H{ } clone kill-sets set
|
||||
current-height new current-height set ;
|
||||
|
||||
: end-stack-analysis ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors
|
|||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
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
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
|
|
@ -215,13 +215,44 @@ M: ##write-barrier generate-insn
|
|||
[ table>> ]
|
||||
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
|
||||
"no-gc" define-label
|
||||
{
|
||||
[ temp1>> ]
|
||||
[ temp2>> ]
|
||||
[ gc-roots>> ]
|
||||
[ gc-root-count>> ]
|
||||
} cleave %gc ;
|
||||
[ [ "no-gc" get ] dip [ temp1>> ] [ temp2>> ] bi %check-nursery ]
|
||||
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
|
||||
[ [ gc-roots>> ] [ temp1>> ] bi save-gc-roots ]
|
||||
[ gc-root-count>> %call-gc ]
|
||||
[ [ gc-roots>> ] [ temp1>> ] bi load-gc-roots ]
|
||||
} cleave
|
||||
"no-gc" resolve-label ;
|
||||
|
||||
M: _loop-entry generate-insn drop %loop-entry ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 alien.c-types ;
|
||||
combinators vectors grouping make alien.c-types combinators.short-circuit ;
|
||||
QUALIFIED: namespaces.private
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
|
|
@ -345,4 +345,17 @@ cell 4 = [
|
|||
dup [ \ vector eq? ] [ drop f ] if
|
||||
over rot [ drop ] [ nip ] if
|
||||
] compile-call
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Coalesing bug reduced from sequence-parser:take-sequence
|
||||
: coalescing-bug-1 ( a b c d -- a b c d )
|
||||
3dup {
|
||||
[ 2drop 0 < ]
|
||||
[ [ drop ] 2dip length > ]
|
||||
[ drop > ]
|
||||
} 3|| [ 3drop f ] [ slice boa ] if swap [ [ length ] bi@ ] 2keep ;
|
||||
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } -10 3 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 0 7 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 0 3 f { 1 2 3 } ] [ { 1 2 3 } 3 2 "hello" coalescing-bug-1 ] unit-test
|
||||
[ 2 3 T{ slice f 1 3 "hello" } { 1 2 3 } ] [ { 1 2 3 } 1 3 "hello" coalescing-bug-1 ] unit-test
|
||||
|
|
@ -128,7 +128,12 @@ HOOK: %alien-global cpu ( dst symbol library -- )
|
|||
|
||||
HOOK: %allot cpu ( dst size class temp -- )
|
||||
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: %epilogue cpu ( n -- )
|
||||
|
|
|
|||
|
|
@ -4,10 +4,10 @@ USING: accessors assocs sequences kernel combinators make math
|
|||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.accessors alien.c-types literals cpu.architecture
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.cfg.instructions compiler.cfg.comparisons
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
|
||||
compiler.units ;
|
||||
compiler.units compiler.constants compiler.codegen ;
|
||||
FROM: cpu.ppc.assembler => B ;
|
||||
IN: cpu.ppc
|
||||
|
||||
|
|
@ -76,8 +76,12 @@ HOOK: reserved-area-size os ( -- n )
|
|||
: xt-save ( n -- i ) 2 cells - ;
|
||||
|
||||
! Next, we have the spill area as well as the FFI parameter area.
|
||||
! They overlap, since basic blocks with FFI calls will never
|
||||
! spill.
|
||||
! It is safe for them to overlap, since basic blocks with FFI calls
|
||||
! 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-save-size ( -- n ) 8 cells ; foldable
|
||||
|
|
@ -85,32 +89,30 @@ HOOK: reserved-area-size os ( -- n )
|
|||
: local@ ( n -- x )
|
||||
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 )
|
||||
cells spill-integer-base + param@ ;
|
||||
spill-integer-offset local@ ;
|
||||
|
||||
: spill-float@ ( n -- offset )
|
||||
double-float-regs reg-size * param@ ;
|
||||
spill-float-offset local@ ;
|
||||
|
||||
! 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
|
||||
! does not overlap with spill slots.
|
||||
: scratch@ ( n -- offset )
|
||||
stack-frame get total-size>>
|
||||
factor-area-size -
|
||||
param-save-size -
|
||||
+ ;
|
||||
|
||||
! GC root area
|
||||
: gc-root@ ( n -- offset )
|
||||
gc-root-offset local@ ;
|
||||
|
||||
! Finally we have the linkage area
|
||||
HOOK: lr-save os ( -- n )
|
||||
|
||||
M: ppc stack-frame-size ( stack-frame -- i )
|
||||
[ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
|
||||
[ params>> ]
|
||||
[ return>> ]
|
||||
tri + +
|
||||
(stack-frame-size)
|
||||
param-save-size +
|
||||
reserved-area-size +
|
||||
factor-area-size +
|
||||
|
|
@ -176,95 +178,28 @@ M: ppc %or OR ;
|
|||
M: ppc %or-imm ORI ;
|
||||
M: ppc %xor XOR ;
|
||||
M: ppc %xor-imm XORI ;
|
||||
M: ppc %shl SLW ;
|
||||
M: ppc %shl-imm swapd SLWI ;
|
||||
M: ppc %shr SRW ;
|
||||
M: ppc %shr-imm swapd SRWI ;
|
||||
M: ppc %sar SRAW ;
|
||||
M: ppc %sar-imm SRAWI ;
|
||||
M: ppc %not NOT ;
|
||||
|
||||
: %alien-invoke-tail ( func dll -- )
|
||||
[ 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 ( -- )
|
||||
:: overflow-template ( label dst src1 src2 insn -- )
|
||||
0 0 LI
|
||||
0 MTXER ; inline
|
||||
0 MTXER
|
||||
dst src2 src1 insn call
|
||||
label BO ; inline
|
||||
|
||||
:: overflow-template ( src1 src2 insn func -- )
|
||||
"no-overflow" define-label
|
||||
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
|
||||
M: ppc %fixnum-add ( label dst src1 src2 -- )
|
||||
[ ADDO. ] overflow-template ;
|
||||
|
||||
:: overflow-template-tail ( src1 src2 insn func -- )
|
||||
"overflow" define-label
|
||||
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-sub ( label dst src1 src2 -- )
|
||||
[ SUBFO. ] overflow-template ;
|
||||
|
||||
M: ppc %fixnum-add ( src1 src2 -- )
|
||||
[ ADDO. ] "overflow_fixnum_add" 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 ;
|
||||
M: ppc %fixnum-mul ( label dst src1 src2 -- )
|
||||
[ MULLWO. ] overflow-template ;
|
||||
|
||||
: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
|
||||
|
||||
|
|
@ -462,19 +397,27 @@ M:: ppc %write-barrier ( src card# table -- )
|
|||
src card# deck-bits SRWI
|
||||
table scratch-reg card# STBX ;
|
||||
|
||||
M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
|
||||
"end" define-label
|
||||
M:: ppc %check-nursery ( label temp1 temp2 -- )
|
||||
temp2 load-zone-ptr
|
||||
temp1 temp2 cell LWZ
|
||||
temp2 temp2 3 cells LWZ
|
||||
temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
|
||||
temp1 0 temp2 CMP ! is here >= end?
|
||||
"end" get BLE
|
||||
! add ALLOT_BUFFER_ZONE to here
|
||||
temp1 temp1 1024 ADDI
|
||||
! 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
|
||||
0 3 LI
|
||||
0 4 LI
|
||||
"inline_gc" f %alien-invoke
|
||||
"end" resolve-label ;
|
||||
3 1 gc-root-base local@ ADDI
|
||||
gc-root-count 4 LI
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: ppc %prologue ( n -- )
|
||||
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system math alien.c-types sequences
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
|
||||
cpu.x86.assembler.operands ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
||||
|
|
|
|||
|
|
@ -435,38 +435,19 @@ M:: x86 %write-barrier ( src card# table -- )
|
|||
table table [] MOV
|
||||
table card# [+] card-mark <byte> MOV ;
|
||||
|
||||
:: check-nursery ( temp1 temp2 -- )
|
||||
M:: x86 %check-nursery ( label temp1 temp2 -- )
|
||||
temp1 load-zone-ptr
|
||||
temp2 temp1 cell [+] MOV
|
||||
temp2 1024 ADD
|
||||
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 -- )
|
||||
temp spill-slot n>> spill-integer@ MOV
|
||||
gc-root gc-root@ temp MOV ;
|
||||
M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ 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 -- )
|
||||
M:: x86 %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
|
||||
|
|
@ -475,15 +456,6 @@ M:: word load-gc-root ( gc-root register temp -- )
|
|||
%prepare-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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ $nl
|
|||
"You can ask a class for its superclass:"
|
||||
{ $subsection superclass }
|
||||
{ $subsection superclasses }
|
||||
{ $subsection subclass-of? }
|
||||
"Class predicates can be used to test instances directly:"
|
||||
{ $subsection "class-predicates" }
|
||||
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
|
||||
|
|
@ -102,7 +103,21 @@ HELP: superclasses
|
|||
}
|
||||
} ;
|
||||
|
||||
{ superclass superclasses } related-words
|
||||
HELP: subclass-of?
|
||||
{ $values
|
||||
{ "class" class }
|
||||
{ "superclass" class }
|
||||
{ "?" boolean }
|
||||
}
|
||||
{ $description "Outputs a boolean value indicating whether " { $snippet "class" } " is at any level a subclass of " { $snippet "superclass" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: classes classes.tuple prettyprint words ;"
|
||||
"tuple-class \\ class subclass-of? ."
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ superclass superclasses subclass-of? } related-words
|
||||
|
||||
HELP: members
|
||||
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
|
||||
|
|
|
|||
|
|
@ -59,6 +59,9 @@ M: predicate reset-word
|
|||
: superclasses ( class -- supers )
|
||||
[ superclass ] follow reverse ;
|
||||
|
||||
: subclass-of? ( class superclass -- ? )
|
||||
swap superclasses member? ;
|
||||
|
||||
: members ( class -- seq )
|
||||
#! Output f for non-classes to work with algebra code
|
||||
dup class? [ "members" word-prop ] [ drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -23,6 +23,24 @@ HELP: file-name
|
|||
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
|
||||
} ;
|
||||
|
||||
HELP: file-extension
|
||||
{ $values { "path" "a pathname string" } { "extension" string } }
|
||||
{ $description "Outputs the extension of " { $snippet "path" } ", or " { $link f } " if the filename has no extension." }
|
||||
{ $examples
|
||||
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-extension ." "f" }
|
||||
{ $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-extension ." "\"vbs\"" }
|
||||
} ;
|
||||
|
||||
HELP: file-stem
|
||||
{ $values { "path" "a pathname string" } { "stem" string } }
|
||||
{ $description "Outputs the " { $link file-name } " of " { $snippet "filename" } " with the file extension removed, if any." }
|
||||
{ $examples
|
||||
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-stem ." "\"gcc\"" }
|
||||
{ $example "USING: io.pathnames prettyprint ;" "\"/home/csi/gui.vbs\" file-stem ." "\"gui\"" }
|
||||
} ;
|
||||
|
||||
{ file-name file-stem file-extension } related-words
|
||||
|
||||
HELP: path-components
|
||||
{ $values { "path" "a pathnames string" } { "seq" sequence } }
|
||||
{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
|
||||
|
|
@ -86,6 +104,8 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
|
|||
"Pathname manipulation:"
|
||||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection file-stem }
|
||||
{ $subsection file-extension }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path-components }
|
||||
{ $subsection prepend-path }
|
||||
|
|
|
|||
|
|
@ -118,7 +118,10 @@ PRIVATE>
|
|||
] if
|
||||
] unless ;
|
||||
|
||||
: file-extension ( filename -- extension )
|
||||
: file-stem ( path -- stem )
|
||||
file-name "." split1-last drop ;
|
||||
|
||||
: file-extension ( path -- extension )
|
||||
file-name "." split1-last nip ;
|
||||
|
||||
: path-components ( path -- seq )
|
||||
|
|
|
|||
|
|
@ -26,8 +26,10 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
[ drop define ]
|
||||
3bi ;
|
||||
|
||||
: reader-quot ( slot-spec -- quot )
|
||||
[
|
||||
GENERIC# reader-quot 1 ( class slot-spec -- quot )
|
||||
|
||||
M: object reader-quot
|
||||
nip [
|
||||
dup offset>> ,
|
||||
\ slot ,
|
||||
dup class>> object bootstrap-word eq?
|
||||
|
|
@ -51,8 +53,12 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
: define-reader ( class slot-spec -- )
|
||||
[ nip name>> define-reader-generic ]
|
||||
[
|
||||
[ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
|
||||
define-typecheck
|
||||
{
|
||||
[ drop ]
|
||||
[ nip name>> reader-word ]
|
||||
[ reader-quot ]
|
||||
[ nip reader-props ]
|
||||
} 2cleave define-typecheck
|
||||
] 2bi ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
|
|
@ -83,8 +89,10 @@ ERROR: bad-slot-value value class ;
|
|||
: writer-quot/fixnum ( slot-spec -- )
|
||||
[ [ >fixnum ] dip ] % writer-quot/check ;
|
||||
|
||||
: writer-quot ( slot-spec -- quot )
|
||||
[
|
||||
GENERIC# writer-quot 1 ( class slot-spec -- quot )
|
||||
|
||||
M: object writer-quot
|
||||
nip [
|
||||
{
|
||||
{ [ dup class>> object bootstrap-word eq? ] [ writer-quot/object ] }
|
||||
{ [ dup class>> "coercer" word-prop ] [ writer-quot/coerce ] }
|
||||
|
|
@ -101,8 +109,12 @@ ERROR: bad-slot-value value class ;
|
|||
|
||||
: define-writer ( class slot-spec -- )
|
||||
[ nip name>> define-writer-generic ] [
|
||||
[ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
|
||||
define-typecheck
|
||||
{
|
||||
[ drop ]
|
||||
[ nip name>> writer-word ]
|
||||
[ writer-quot ]
|
||||
[ nip writer-props ]
|
||||
} 2cleave define-typecheck
|
||||
] 2bi ;
|
||||
|
||||
: setter-word ( name -- word )
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ HELP: CM-FUNCTION:
|
|||
"C-LIBRARY: exlib"
|
||||
""
|
||||
"C-INCLUDE: <stdio.h>"
|
||||
"C-INCLUDE: <stdlib.h>"
|
||||
"CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
|
||||
" *x = a + b;"
|
||||
" *y = a - b;"
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: benchmark.beust2
|
|||
! http://crazybob.org/BeustSequence.java.html
|
||||
|
||||
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
|
||||
10 first - [| i |
|
||||
10 first - iota [| i |
|
||||
[let* | digit [ i first + ]
|
||||
mask [ digit 2^ ]
|
||||
value' [ i value + ] |
|
||||
|
|
@ -29,7 +29,7 @@ IN: benchmark.beust2
|
|||
] any? ; inline recursive
|
||||
|
||||
:: count-numbers ( max listener -- )
|
||||
10 [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
|
||||
10 iota [ 1+ 1 1 0 max listener (count-numbers) ] any? drop ;
|
||||
inline
|
||||
|
||||
:: beust ( -- )
|
||||
|
|
|
|||
|
|
@ -54,6 +54,6 @@ IN: benchmark.pidigits
|
|||
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
|
||||
|
||||
: pidigits-main ( -- )
|
||||
10000 pidigits ;
|
||||
2000 pidigits ;
|
||||
|
||||
MAIN: pidigits-main
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
USING: classes.tuple.change-tracking tools.test strings accessors kernel continuations ;
|
||||
IN: classes.tuple.change-tracking.tests
|
||||
|
||||
TUPLE: resource < change-tracking-tuple
|
||||
{ pathname string } ;
|
||||
|
||||
: <resource> ( pathname -- resource ) f swap resource boa ;
|
||||
|
||||
[ t ] [ "foo" <resource> "bar" >>pathname changed?>> ] unit-test
|
||||
[ f ] [ "foo" <resource> [ 123 >>pathname ] [ drop ] recover changed?>> ] unit-test
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors classes classes.tuple fry kernel sequences slots ;
|
||||
IN: classes.tuple.change-tracking
|
||||
|
||||
TUPLE: change-tracking-tuple
|
||||
{ changed? boolean } ;
|
||||
|
||||
PREDICATE: change-tracking-tuple-class < tuple-class
|
||||
change-tracking-tuple subclass-of? ;
|
||||
|
||||
: changed? ( tuple -- changed? ) changed?>> ; inline
|
||||
: clear-changed ( tuple -- tuple ) f >>changed? ; inline
|
||||
|
||||
: filter-changed ( sequence -- sequence' ) [ changed? ] filter ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: change-tracking-tuple-class writer-quot ( class slot-spec -- )
|
||||
[ call-next-method ]
|
||||
[ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tuple classes that keep track of when they've been modified
|
||||
|
|
@ -221,7 +221,7 @@ BEFORE: bunny-world begin-world
|
|||
bunny-uniforms boa ;
|
||||
|
||||
: draw-bunny ( world -- )
|
||||
T{ depth-state { comparison cmp-less } } set-gpu-state*
|
||||
T{ depth-state { comparison cmp-less } } set-gpu-state
|
||||
|
||||
[
|
||||
sobel>> framebuffer>> {
|
||||
|
|
@ -247,7 +247,7 @@ BEFORE: bunny-world begin-world
|
|||
sobel-uniforms boa ;
|
||||
|
||||
: draw-sobel ( world -- )
|
||||
T{ depth-state { comparison f } } set-gpu-state*
|
||||
T{ depth-state { comparison f } } set-gpu-state
|
||||
|
||||
sobel>> {
|
||||
{ "primitive-mode" [ drop triangle-strip-mode ] }
|
||||
|
|
@ -260,7 +260,7 @@ BEFORE: bunny-world begin-world
|
|||
[ draw-bunny ] [ draw-sobel ] bi ;
|
||||
|
||||
: draw-loading ( world -- )
|
||||
T{ depth-state { comparison f } } set-gpu-state*
|
||||
T{ depth-state { comparison f } } set-gpu-state
|
||||
|
||||
loading>> {
|
||||
{ "primitive-mode" [ drop triangle-strip-mode ] }
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: byte-arrays classes gpu.buffers help.markup help.syntax
|
||||
USING: alien byte-arrays classes gpu.buffers help.markup help.syntax
|
||||
images kernel math ;
|
||||
IN: gpu.textures
|
||||
|
||||
|
|
@ -228,7 +228,11 @@ HELP: texture-cube-map
|
|||
{ texture-cube-map <texture-cube-map> } related-words
|
||||
|
||||
HELP: texture-data
|
||||
{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." }
|
||||
{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } "."
|
||||
{ $list
|
||||
{ "The " { $snippet "ptr" } " slot references either CPU memory (as a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } " that contains the image data." }
|
||||
{ "The " { $snippet "component-order" } " and " { $snippet "component-type" } " slots determine the " { $link component-order } " and " { $link component-type } " of the referenced data." }
|
||||
} }
|
||||
{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
|
||||
|
||||
{ texture-data <texture-data> } related-words
|
||||
|
|
@ -254,15 +258,15 @@ HELP: texture-filter
|
|||
{ $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ;
|
||||
|
||||
HELP: texture-parameters
|
||||
{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:"
|
||||
{ $class-description "A " { $snippet "texture-parameters" } " tuple is supplied when constructing a " { $link texture } " to control the wrapping, filtering, and level-of-detail handling of the texture. These tuples have the following slots:"
|
||||
{ $list
|
||||
{ "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." }
|
||||
{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
|
||||
{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among the sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
|
||||
{ "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." }
|
||||
{ "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." }
|
||||
{ "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." }
|
||||
{ "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." }
|
||||
{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." }
|
||||
{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithms of the dimensions of the highest level of detail image." }
|
||||
} } ;
|
||||
|
||||
{ texture-parameters set-texture-parameters } related-words
|
||||
|
|
|
|||
|
|
@ -26,14 +26,14 @@ TUPLE: cube-map-face
|
|||
{ axis cube-map-axis read-only } ;
|
||||
C: <cube-map-face> cube-map-face
|
||||
|
||||
UNION: texture-data-target
|
||||
texture-1d texture-2d texture-3d cube-map-face ;
|
||||
UNION: texture-1d-data-target
|
||||
texture-1d ;
|
||||
UNION: texture-2d-data-target
|
||||
texture-2d texture-rectangle texture-1d-array cube-map-face ;
|
||||
UNION: texture-3d-data-target
|
||||
texture-3d texture-2d-array ;
|
||||
UNION: texture-data-target
|
||||
texture-1d-data-target texture-2d-data-target texture-3d-data-target ;
|
||||
|
||||
M: texture dispose
|
||||
[ [ delete-texture ] when* f ] change-handle drop ;
|
||||
|
|
|
|||
|
|
@ -53,10 +53,8 @@ cell code_relocation_base;
|
|||
|
||||
static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
|
||||
{
|
||||
cell good_size = h->code_size + (1 << 19);
|
||||
|
||||
if(good_size > p->code_size)
|
||||
p->code_size = good_size;
|
||||
if(h->code_size > p->code_size)
|
||||
fatal_error("Code heap too small to fit image",h->code_size);
|
||||
|
||||
init_code_heap(p->code_size);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue