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

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

db4
Bruno Deferrari 2008-11-11 23:57:07 -02:00
parent a1137a95f9 782671a50c
commit 3eee17f7a4
649 changed files with 11952 additions and 12099 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -170,7 +170,7 @@ vm/resources.o:
$(CC) -c $(CFLAGS) -o $@ $<
.S.o:
$(CC) -c $(CFLAGS) -o $@ $<
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<

2
basis/alien/c-types/c-types.factor
View File

@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
[ >float ] >>unboxer-quot
"double" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
"long" "ptrdiff_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

6
basis/alien/strings/strings-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
@ -28,3 +28,7 @@ unit-test
] unit-test
[ f ] [ f utf8 alien>string ] unit-test
[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test

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

@ -7,7 +7,7 @@ hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer ;
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
@ -89,10 +89,24 @@ nl
. malloc calloc free memcpy
} compile-uncompiled
"." write flush
{ build-tree } compile-uncompiled
"." write flush
{ optimize-tree } compile-uncompiled
"." write flush
{ optimize-cfg } compile-uncompiled
"." write flush
{ (compile) } compile-uncompiled
"." write flush
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush

53
basis/bootstrap/image/image.factor
View File

@ -8,12 +8,19 @@ grouping growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order math.private accessors slots.private ;
io.encodings.binary math.order math.private accessors
slots.private compiler.units ;
IN: bootstrap.image
: arch ( os cpu -- arch )
{
{ "ppc" [ "-ppc" append ] }
{ "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
[ nip ]
} case ;
: my-arch ( -- arch )
cpu name>>
dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
os name>> cpu name>> arch ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
@ -24,7 +31,7 @@ IN: bootstrap.image
: images ( -- seq )
{
"x86.32"
"x86.64"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
@ -367,31 +374,35 @@ M: byte-array '
M: tuple ' emit-tuple ;
M: tuple-layout '
[
[
{
[ hashcode>> , ]
[ class>> , ]
[ size>> , ]
[ superclasses>> , ]
[ echelon>> , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache-object ;
M: tombstone '
state>> "((tombstone))" "((empty))" ?
"hashtables.private" lookup def>> first
[ emit-tuple ] cache-object ;
! Arrays
M: array '
: emit-array ( array -- offset )
[ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ;
! This is a hack. We need to detect arrays which are tuple
! layout arrays so that they can be internalized, but making
! them a built-in type is not worth it.
PREDICATE: tuple-layout-array < array
dup length 5 >= [
[ first tuple-class? ]
[ second fixnum? ]
[ third fixnum? ]
tri and and
] [ drop f ] if ;
M: tuple-layout-array '
[
[ dup integer? [ <fake-bignum> ] when ] map
emit-array
] cache-object ;
! Quotations
M: quotation '
@ -458,6 +469,8 @@ M: quotation '
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
"Building generic words..." print flush
call-remake-generics-hook
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush

16
basis/bootstrap/random/random.factor
View File

@ -1,16 +0,0 @@
USING: vocabs.loader sequences system
random random.mersenne-twister combinators init
namespaces random ;
IN: bootstrap.random
"random.mersenne-twister" require
{
{ [ os windows? ] [ "random.windows" require ] }
{ [ os unix? ] [ "random.unix" require ] }
} cond
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
] "bootstrap.random" add-init-hook

20
basis/bootstrap/stage2.factor
View File

@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: default-image-name ( -- string )
@ -30,11 +32,15 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ;
: print-report ( time -- )
: print-time ( time -- )
1000 /i
60 /mod swap
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
number>string write
" minutes and " write number>string write " seconds." print ;
: print-report ( -- )
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
@ -46,11 +52,11 @@ SYMBOL: bootstrap-time
[
! We time bootstrap
millis >r
millis
default-image-name "output-image" set-global
"math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
@ -71,6 +77,8 @@ SYMBOL: bootstrap-time
[
load-components
millis over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
:errors
@ -92,7 +100,7 @@ SYMBOL: bootstrap-time
] [ print-error 1 exit ] recover
] set-boot-quot
millis r> - dup bootstrap-time set-global
millis swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit

9
basis/cocoa/messages/messages.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
words cocoa.runtime io macros memoize debugger fry
io.encodings.ascii effects compiler.generator libc libc.private ;
combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry ;
IN: cocoa.messages
: make-sender ( method function -- quot )

0
unfinished/compiler/alien/alien.factor → basis/compiler/alien/alien.factor
View File

56
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor Normal file
View File

@ -0,0 +1,56 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis cpu.architecture tools.test
kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [
{
T{ ##peek f V int-regs 2 D 1 f }
T{ ##box-alien f V int-regs 1 V int-regs 2 }
T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[ ] [
{
T{ ##load-indirect f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 1 D 0 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 2 f }
T{ ##replace f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
} alias-analysis
] unit-test
[
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##copy f V int-regs 3 V int-regs 2 f }
T{ ##copy f V int-regs 4 V int-regs 1 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
}
] [
{
T{ ##peek f V int-regs 1 D 1 f }
T{ ##peek f V int-regs 2 D 0 f }
T{ ##replace f V int-regs 1 D 0 f }
T{ ##replace f V int-regs 2 D 1 f }
T{ ##peek f V int-regs 3 D 1 f }
T{ ##peek f V int-regs 4 D 0 f }
T{ ##replace f V int-regs 3 D 0 f }
T{ ##replace f V int-regs 4 D 1 f }
} alias-analysis
] unit-test

118
unfinished/compiler/cfg.bluesky/alias/alias.factor → basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences
accessors vectors combinators sets compiler.vops compiler.cfg ;
IN: compiler.cfg.alias
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop ;
IN: compiler.cfg.alias-analysis
! Alias analysis -- must be run after compiler.cfg.stack.
! Alias analysis -- assumes compiler.cfg.height has already run.
!
! We try to eliminate redundant slot and stack
! traffic using some simple heuristics.
@ -69,8 +71,8 @@ SYMBOL: vregs>acs
: check [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by %%allot, %peek and %%slot can
#! ever be used as valid inputs to %%slot and %%set-slot,
#! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
vregs>acs get at check ;
@ -175,31 +177,30 @@ SYMBOL: heap-ac
[ kill-constant-set-slot ] 2bi
] [ nip kill-computed-set-slot ] if ;
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
SYMBOL: constants
: constant ( vreg -- n/f )
#! Return an %iconst value, or f if the vreg was not
#! assigned by an %iconst.
#! Return a ##load-immediate value, or f if the vreg was not
#! assigned by an ##load-immediate.
resolve constants get at ;
! We treat slot accessors and stack traffic alike
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: %peek insn-slot# n>> ;
M: %replace insn-slot# n>> ;
M: %%slot insn-slot# slot>> constant ;
M: %%set-slot insn-slot# slot>> constant ;
M: ##peek insn-slot# loc>> n>> ;
M: ##replace insn-slot# loc>> n>> ;
M: ##slot insn-slot# slot>> constant ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: %peek insn-object stack>> ;
M: %replace insn-object stack>> ;
M: %%slot insn-object obj>> resolve ;
M: %%set-slot insn-object obj>> resolve ;
M: ##peek insn-object loc>> class ;
M: ##replace insn-object loc>> class ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
: init-alias-analysis ( -- )
H{ } clone histories set
@ -212,24 +213,37 @@ M: %%set-slot insn-object obj>> resolve ;
0 ac-counter set
next-ac heap-ac set
%data next-ac set-ac
%retain next-ac set-ac ;
ds-loc next-ac set-ac
rs-loc next-ac set-ac ;
GENERIC: analyze-aliases ( insn -- insn' )
GENERIC: analyze-aliases* ( insn -- insn' )
M: %iconst analyze-aliases
dup [ value>> ] [ out>> ] bi constants get set-at ;
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: %%allot analyze-aliases
M: ##load-indirect analyze-aliases*
dup dst>> set-heap-ac ;
M: ##allot analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup out>> set-new-ac ;
dup dst>> set-new-ac ;
M: read-op analyze-aliases
dup out>> set-heap-ac
dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
M: ##box-float analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##box-alien analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
dup dst>> set-new-ac ;
M: ##read analyze-aliases*
dup dst>> set-heap-ac
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip %copy boa analyze-aliases nip
2nip f \ ##copy boa analyze-aliases* nip
] [
drop remember-slot
] if ;
@ -239,21 +253,20 @@ M: read-op analyze-aliases
#! from?
live-slot = ;
M: write-op analyze-aliases
M: ##write analyze-aliases*
dup
[ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
3dup idempotent? [
2drop 2drop nop
] [
[ remember-set-slot drop ] [ load-slot ] 3bi
] if ;
[ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
[ remember-set-slot drop ] [ load-slot ] 3bi ;
M: %copy analyze-aliases
M: ##copy analyze-aliases*
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
dup record-copy ;
M: vop analyze-aliases ;
M: insn analyze-aliases* ;
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
SYMBOL: live-stores
@ -264,30 +277,35 @@ SYMBOL: live-stores
] map concat unique
live-stores set ;
GENERIC: eliminate-dead-store ( insn -- insn' )
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: (eliminate-dead-store) ( insn -- insn' )
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
insn# get live-stores get key? [
drop nop
drop f
] unless
] when ;
M: %replace eliminate-dead-store
M: ##replace eliminate-dead-stores*
#! Writes to above the top of the stack can be pruned also.
#! This is sound since any such writes are not observable
#! after the basic block, and any reads of those locations
#! will have been converted to copies by analyze-slot,
#! and the final stack height of the basic block is set at
#! the beginning by compiler.cfg.stack.
dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
M: vop eliminate-dead-store ;
M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
M: insn eliminate-dead-stores* ;
: eliminate-dead-stores ( insns -- insns' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis ( insns -- insns' )
init-alias-analysis
[ insn# set analyze-aliases ] map-index
analyze-aliases
compute-live-stores
[ insn# set eliminate-dead-store ] map-index ;
eliminate-dead-stores ;

0
basis/compiler/generator/authors.txt → basis/compiler/cfg/builder/authors.txt
View File

105
basis/compiler/cfg/builder/builder-tests.factor Normal file
View File

@ -0,0 +1,105 @@
IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences
words sequences.private fry prettyprint alien alien.accessors
math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
\ build-cfg must-infer
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
{
[ ]
[ dup ]
[ swap ]
[ >r r> ]
[ fixnum+ ]
[ fixnum+fast ]
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]
[ fixnum< ]
[ 5 fixnum< ]
[ float+ ]
[ 3.0 float+ ]
[ float<= ]
[ fixnum>bignum ]
[ bignum>fixnum ]
[ fixnum>float ]
[ float>fixnum ]
[ 3 f <array> ]
[ [ 1 ] [ 2 ] if ]
[ fixnum< [ 1 ] [ 2 ] if ]
[ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
[ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
} [
unit-test-cfg
] each
: test-1 ( -- ) test-1 ;
: test-2 ( -- ) 3 . test-2 ;
: test-3 ( a -- b ) dup [ test-3 ] when ;
{
test-1
test-2
test-3
} [ unit-test-cfg ] each
{
byte-array
simple-alien
alien
POSTPONE: f
} [| class |
{
alien-signed-1
alien-signed-2
alien-signed-4
alien-unsigned-1
alien-unsigned-2
alien-unsigned-4
alien-cell
alien-float
alien-double
} [| word |
{ class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ class fixnum } word '[ _ declare _ execute ] unit-test-cfg
] each
{
set-alien-signed-1
set-alien-signed-2
set-alien-signed-4
set-alien-unsigned-1
set-alien-unsigned-2
set-alien-unsigned-4
} [| word |
{ fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
{ fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
] each
{ float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
{ float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
{ float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
{ pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
] each

297
basis/compiler/cfg/builder/builder.factor Executable file
View File

@ -0,0 +1,297 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
layouts alien.c-types alien.structs
stack-checker.inlining cpu.architecture
compiler.tree
compiler.tree.builder
compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.instructions
compiler.alien ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
: stop-iterating ( -- next ) end-basic-block f ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
SYMBOL: loops
SYMBOL: first-basic-block
! Basic block after prologue, makes recursion faster
SYMBOL: current-label-start
: add-procedure ( -- )
basic-block get current-word get current-label get
<cfg> procedures get push ;
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
H{ } clone loops set
current-label set
current-word set
add-procedure ;
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
GENERIC: emit-node ( node -- next )
: check-basic-block ( node -- node' )
basic-block get [ drop f ] unless ; inline
: emit-nodes ( nodes -- )
[ current-node emit-node check-basic-block ] iterate-nodes ;
: begin-word ( -- )
#! We store the basic block after the prologue as a loop
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
##prologue
##branch
begin-basic-block
basic-block get first-basic-block set ;
: (build-cfg) ( nodes word label -- )
[
begin-word
V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
dup (build-cfg)
] with-variable
] keep ;
: local-recursive-call ( basic-block -- next )
##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
{
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
{ [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
: compile-recursive ( node -- next )
[ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: compile-loop ( node -- next )
##loop-entry
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
iterate-next ;
M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: emit-branch ( obj -- final-bb )
[
begin-basic-block
emit-nodes
basic-block get dup [ ##branch ] when
] with-scope ;
: emit-if ( node -- )
children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
] [ drop f f ] if ;
: trivial-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ t eq? ] when ]
[ trivial-branch? [ f eq? ] when ] bi*
and ;
: emit-trivial-if ( -- )
ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
[ trivial-branch? [ f eq? ] when ]
[ trivial-branch? [ t eq? ] when ] bi*
and ;
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
M: #if emit-node
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
} cond iterate-next ;
! #dispatch
: trivial-dispatch-branch? ( nodes -- ? )
dup length 1 = [
first dup #call? [
word>> "intrinsic" word-prop not
] [ drop f ] if
] [ drop f ] if ;
: dispatch-branch ( nodes word -- label )
over trivial-dispatch-branch? [
drop first word>>
] [
gensym [
[
V{ } clone node-stack set
##prologue
begin-basic-block
emit-nodes
basic-block get [
##epilogue
##return
end-basic-block
] when
] with-cfg-builder
] keep
] if ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
##dispatch-label
] each ;
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
gensym dup t "inlined-block" set-word-prop ;
M: #dispatch emit-node
tail-call? [
emit-dispatch stop-iterating
] [
current-word get <dispatch-block> [
[
begin-word
emit-dispatch
] with-cfg-builder
] keep emit-call
] if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
: emit-shuffle ( effect -- )
[ out>> ] [ in>> dup length ds-load zip ] bi
'[ _ at ] map ds-store ;
M: #shuffle emit-node
shuffle-effect emit-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ neg ##inc-d ] [ ds-load rs-store ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ neg ##inc-r ] [ rs-load ds-store ] if
iterate-next ;
! #return
M: #return emit-node
drop ##epilogue ##return stop-iterating ;
M: #return-recursive emit-node
label>> id>> loops get key?
[ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
! FFI
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
{
{ [ dup c-struct? not ] [ drop 0 ] }
{ [ dup large-struct? not ] [ drop 2 cells ] }
[ heap-size ]
} cond ;
: <alien-stack-frame> ( params -- stack-frame )
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
: emit-alien-node ( node quot -- next )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
begin-basic-block iterate-next ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
dup [ ##alien-callback ] emit-alien-node drop
##epilogue
params>> ##callback-return
] with-cfg-builder
iterate-next ;
! No-op nodes
M: #introduce emit-node drop iterate-next ;
M: #copy emit-node drop iterate-next ;
M: #enter-recursive emit-node drop iterate-next ;
M: #phi emit-node drop iterate-next ;

0
basis/compiler/generator/summary.txt → basis/compiler/cfg/builder/summary.txt
View File

0
basis/compiler/generator/tags.txt → basis/compiler/cfg/builder/tags.txt
View File

24
unfinished/compiler/cfg/cfg.factor → basis/compiler/cfg/cfg.factor
View File

@ -1,25 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sequences sets fry ;
USING: kernel arrays vectors accessors namespaces ;
IN: compiler.cfg
TUPLE: cfg entry word label ;
C: <cfg> cfg
! - "number" and "visited" is used by linearization.
TUPLE: basic-block < identity-tuple
visited
id
number
instructions
successors ;
{ instructions vector }
{ successors vector }
{ predecessors vector } ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
V{ } clone >>successors ;
V{ } clone >>successors
V{ } clone >>predecessors
\ basic-block counter >>id ;
TUPLE: mr instructions word label ;
TUPLE: cfg { entry basic-block } word label ;
C: <cfg> cfg
TUPLE: mr { instructions array } word label spill-counts ;
: <mr> ( instructions word label -- mr )
mr new

12
basis/compiler/cfg/copy-prop/copy-prop.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors ;
IN: compiler.cfg.copy-prop
SYMBOL: copies
: resolve ( vreg -- vreg )
dup copies get at swap or ;
: record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

8
basis/compiler/cfg/dead-code/dead-code-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [
{ T{ ##load-immediate f V int-regs 134 16 } }
eliminate-dead-code
] unit-test

61
basis/compiler/cfg/dead-code/dead-code.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use ;
IN: compiler.cfg.dead-code
! Dead code elimination -- assumes compiler.cfg.alias-analysis
! has already run.
! Maps vregs to sequences of vregs
SYMBOL: liveness-graph
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
! mapping vregs to stack locations
SYMBOL: vregs>locs
: init-dead-code ( -- )
H{ } clone liveness-graph set
H{ } clone live-vregs set
H{ } clone vregs>locs set ;
GENERIC: compute-liveness ( insn -- )
M: ##flushable compute-liveness
[ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
M: ##peek compute-liveness
[ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
[ call-next-method ]
bi ;
: live-replace? ( ##replace -- ? )
[ src>> vregs>locs get at ] [ loc>> ] bi = not ;
M: ##replace compute-liveness
dup live-replace? [ call-next-method ] [ drop ] if ;
: record-live ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
[ liveness-graph get at record-live ]
bi
] if
] each ;
M: insn compute-liveness uses-vregs record-live ;
GENERIC: live-insn? ( insn -- ? )
M: ##flushable live-insn? dst>> live-vregs get key? ;
M: ##replace live-insn? live-replace? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( insns -- insns' )
init-dead-code
[ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;

42
basis/compiler/cfg/debugger/debugger.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.two-operand compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
[ build-tree-from-word nip optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
convert-two-operand
allocate-registers? get
[ linear-scan build-stack-frame ] when
] map ;
: insn. ( insn -- )
tuple>array allocate-registers? get [ but-last ] unless
[ pprint bl ] each nl ;
: mr. ( mrs -- )
[
"=== word: " write
dup word>> pprint
", label: " write
dup label>> pprint nl nl
instructions>> [ insn. ] each
nl
] each ;

46
basis/compiler/cfg/def-use/def-use.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ;
M: ##effect uses-vregs src>> 1array ;
M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: insn uses-vregs drop f ;
UNION: vreg-insn
##flushable
##write-barrier
##dispatch
##effect
##conditional-branch
##compare-imm-branch
_conditional-branch
_compare-imm-branch ;

73
basis/compiler/cfg/hats/hats.factor Normal file
View File

@ -0,0 +1,73 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel layouts math namespaces
sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
: i int-regs next-vreg ; inline
: ^^i i dup ; inline
: ^^i1 [ ^^i ] dip ; inline
: ^^i2 [ ^^i ] 2dip ; inline
: ^^i3 [ ^^i ] 3dip ; inline
: d double-float-regs next-vreg ; inline
: ^^d d dup ; inline
: ^^d1 [ ^^d ] dip ; inline
: ^^d2 [ ^^d ] 2dip ; inline
: ^^d3 [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

51
basis/compiler/cfg/height/height.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
IN: compiler.cfg.height
! Combine multiple stack height changes into one at the
! start of the basic block.
SYMBOL: ds-height
SYMBOL: rs-height
GENERIC: compute-heights ( insn -- )
M: ##inc-d compute-heights n>> ds-height [ + ] change ;
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
M: insn compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn' )
: normalize-inc-d/r ( insn stack -- insn' )
swap n>> '[ _ - ] change f ; inline
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc loc-stack drop ds-height ;
M: rs-loc loc-stack drop rs-height ;
GENERIC: <loc> ( n stack -- loc )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
: normalize-peek/replace ( insn -- insn' )
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
M: ##peek normalize-height* normalize-peek/replace ;
M: ##replace normalize-height* normalize-peek/replace ;
M: insn normalize-height* ;
: normalize-height ( insns -- insns' )
0 ds-height set
0 rs-height set
[ [ compute-heights ] each ]
[ [ [ normalize-height* ] map sift ] with-scope ] bi
ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;

228
basis/compiler/cfg/instructions/instructions.factor Normal file
View File

@ -0,0 +1,228 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
! Instruction with no side effects; if 'out' is never read, we
! can eliminate it.
TUPLE: ##flushable < insn { dst vreg } ;
! Instruction which is referentially transparent; we can replace
! repeated computation with a reference to a previous value
TUPLE: ##pure < ##flushable ;
TUPLE: ##unary < ##pure { src vreg } ;
TUPLE: ##unary/temp < ##unary { temp vreg } ;
TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
TUPLE: ##commutative < ##binary ;
TUPLE: ##commutative-imm < ##binary-imm ;
! Instruction only used for its side effect, produces no values
TUPLE: ##effect < insn { src vreg } ;
! Read/write ops: candidates for alias analysis
TUPLE: ##read < ##flushable ;
TUPLE: ##write < ##effect ;
TUPLE: ##alien-getter < ##flushable { src vreg } ;
TUPLE: ##alien-setter < ##effect { value vreg } ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##load-indirect < ##pure obj ;
GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-indirect ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
{ params integer }
{ return integer }
{ total-size integer }
spill-counts ;
INSN: ##stack-frame stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Slot access
INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##add-imm < ##commutative-imm ;
INSN: ##sub < ##binary ;
INSN: ##sub-imm < ##binary-imm ;
INSN: ##mul < ##commutative ;
INSN: ##mul-imm < ##commutative-imm ;
INSN: ##and < ##commutative ;
INSN: ##and-imm < ##commutative-imm ;
INSN: ##or < ##commutative ;
INSN: ##or-imm < ##commutative-imm ;
INSN: ##xor < ##commutative ;
INSN: ##xor-imm < ##commutative-imm ;
INSN: ##shl-imm < ##binary-imm ;
INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
! Bignum/integer conversion
INSN: ##integer>bignum < ##unary/temp ;
INSN: ##bignum>integer < ##unary/temp ;
! Float arithmetic
INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
INSN: ##copy-float < ##unary ;
INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
: ##unbox-c-ptr ( dst src class temp -- )
{
{ [ over \ f class<= ] [ 2drop ##unbox-f ] }
{ [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
{ [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
[ nip ##unbox-any-c-ptr ]
} cond ;
! Alien accessors
INSN: ##alien-unsigned-1 < ##alien-getter ;
INSN: ##alien-unsigned-2 < ##alien-getter ;
INSN: ##alien-unsigned-4 < ##alien-getter ;
INSN: ##alien-signed-1 < ##alien-getter ;
INSN: ##alien-signed-2 < ##alien-getter ;
INSN: ##alien-signed-4 < ##alien-getter ;
INSN: ##alien-cell < ##alien-getter ;
INSN: ##alien-float < ##alien-getter ;
INSN: ##alien-double < ##alien-getter ;
INSN: ##set-alien-integer-1 < ##alien-setter ;
INSN: ##set-alien-integer-2 < ##alien-setter ;
INSN: ##set-alien-integer-4 < ##alien-setter ;
INSN: ##set-alien-cell < ##alien-setter ;
INSN: ##set-alien-float < ##alien-setter ;
INSN: ##set-alien-double < ##alien-setter ;
! Memory allocation
INSN: ##allot < ##flushable size class { temp vreg } ;
INSN: ##write-barrier < ##effect card# table ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
INSN: ##alien-callback params ;
INSN: ##callback-return params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##loop-entry ;
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
SYMBOL: cc=
SYMBOL: cc>
SYMBOL: cc>=
SYMBOL: cc/=
: negate-cc ( cc -- cc' )
H{
{ cc< cc>= }
{ cc<= cc> }
{ cc> cc<= }
{ cc>= cc< }
{ cc= cc/= }
{ cc/= cc= }
} at ;
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
{ cc<= { +lt+ +eq+ } }
{ cc= { +eq+ } }
{ cc>= { +eq+ +gt+ } }
{ cc> { +gt+ } }
{ cc/= { +lt+ +gt+ } }
} at memq? ;
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
INSN: ##compare < ##binary cc ;
INSN: ##compare-imm < ##binary-imm cc ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _epilogue stack-frame ;
INSN: _label id ;
INSN: _gc ;
INSN: _branch label ;
TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
INSN: _compare-branch < _conditional-branch ;
INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _spill src class n ;
INSN: _reload dst class n ;
INSN: _spill-counts counts ;

8
unfinished/compiler/cfg/instructions/syntax/syntax.factor → basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -4,11 +4,15 @@ USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser ;
IN: compiler.cfg.instructions.syntax
TUPLE: insn ;
: insn-word ( -- word )
#! We want to put the insn tuple in compiler.cfg.instructions,
#! but we cannot have circularity between that vocabulary and
#! this one.
"insn" "compiler.cfg.instructions" lookup ;
: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn ] when ] dip
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop dup '[ f _ boa , ] define-inline ]

108
basis/compiler/cfg/intrinsics/alien/alien.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra
fry locals combinators cpu.architecture
compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.alien
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
: (prepare-alien-accessor) ( class -- offset-vreg )
[ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
: prepare-alien-accessor ( infos -- offset-vreg )
<reversed> [ second class>> ] [ first ] bi
dup value-info-small-fixnum? [
literal>> (prepare-alien-accessor-imm)
] [ drop (prepare-alien-accessor) ] if ;
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
[ infos prepare-alien-accessor quot call ]
[ node emit-primitive ]
if
] ; inline
: inline-alien-getter? ( infos -- ? )
[ first class>> c-ptr class<= ]
[ second class>> fixnum class<= ]
bi and ;
: inline-alien-getter ( node quot -- )
'[ @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
'[ first class>> _ class<= ]
[ second class>> c-ptr class<= ]
[ third class>> fixnum class<= ]
tri and and ;
: inline-alien-integer-setter ( node quot -- )
'[ ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
[ dup node-input-infos first class>> ] dip
'[ ds-pop _ ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
'[ ds-pop ^^unbox-float @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-unsigned-getter ( node n -- )
'[
_ {
{ 1 [ ^^alien-unsigned-1 ] }
{ 2 [ ^^alien-unsigned-2 ] }
{ 4 [ ^^alien-unsigned-4 ] }
} case ^^tag-fixnum
] inline-alien-getter ;
: emit-alien-signed-getter ( node n -- )
'[
_ {
{ 1 [ ^^alien-signed-1 ] }
{ 2 [ ^^alien-signed-2 ] }
{ 4 [ ^^alien-signed-4 ] }
} case ^^tag-fixnum
] inline-alien-getter ;
: emit-alien-integer-setter ( node n -- )
'[
_ {
{ 1 [ ##set-alien-integer-1 ] }
{ 2 [ ##set-alien-integer-2 ] }
{ 4 [ ##set-alien-integer-4 ] }
} case
] inline-alien-integer-setter ;
: emit-alien-cell-getter ( node -- )
[ ^^alien-cell ^^box-alien ] inline-alien-getter ;
: emit-alien-cell-setter ( node -- )
[ ##set-alien-cell ] inline-alien-cell-setter ;
: emit-alien-float-getter ( node reg-class -- )
'[
_ {
{ single-float-regs [ ^^alien-float ] }
{ double-float-regs [ ^^alien-double ] }
} case ^^box-float
] inline-alien-getter ;
: emit-alien-float-setter ( node reg-class -- )
'[
_ {
{ single-float-regs [ ##set-alien-float ] }
{ double-float-regs [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;

68
basis/compiler/cfg/intrinsics/allot/allot.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
'[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
[ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
[ second ds-load ] [ ^^load-literal ] bi prefix ;
: emit-<tuple-boa> ( node -- )
dup node-input-infos peek literal>>
dup array? [
nip
ds-drop
[ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
: store-length ( len reg -- )
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
: store-initial-element ( elt reg len -- )
[ 2 + object tag-number ##set-slot-imm ] with with each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
:: emit-<array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<array>? [
[let | elt [ ds-pop ]
reg [ len ^^allot-array ] |
ds-drop
len reg store-length
elt reg len store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;
: expand-<byte-array>? ( obj -- ? )
dup integer? [ 0 32 between? ] [ drop f ] if ;
: bytes>cells ( m -- n ) cell align cell /i ;
:: emit-<byte-array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<byte-array>? [
[let | elt [ 0 ^^load-literal ]
reg [ len ^^allot-byte-array ] |
ds-drop
len reg store-length
elt reg len bytes>cells store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;

66
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor Normal file
View File

@ -0,0 +1,66 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.fixnum
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ]
[ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
[ ]
tri*
call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
[ infos imm-insn (emit-fixnum-imm-op) ]
[ insn (emit-fixnum-op) ]
if
ds-push
] ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-fixnum? [
nip
[ ds-drop ds-pop ] dip
second literal>> dup sgn {
{ -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
{ 0 [ drop ] }
{ 1 [ ^^shl-imm ] }
} case
ds-push
] [ drop emit-primitive ] if ;
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
: (emit-fixnum*fast-imm) ( infos -- dst )
ds-drop
[ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
ds-push ;
: emit-fixnum-comparison ( node cc -- )
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;

19
basis/compiler/cfg/intrinsics/float/float.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.float
: emit-float-op ( insn -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
ds-push ; inline
: emit-float-comparison ( cc -- )
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
: emit-fixnum>float ( -- )
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;

144
basis/compiler/cfg/intrinsics/intrinsics.factor Normal file
View File

@ -0,0 +1,144 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: qualified words sequences kernel combinators
cpu.architecture
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
QUALIFIED: kernel.private
QUALIFIED: slots.private
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
kernel.private:tag
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
math.private:fixnum-bitor
math.private:fixnum-bitxor
math.private:fixnum-shift-fast
math.private:fixnum-bitnot
math.private:fixnum*fast
math.private:fixnum<
math.private:fixnum<=
math.private:fixnum>=
math.private:fixnum>
math.private:bignum>fixnum
math.private:fixnum>bignum
kernel:eq?
slots.private:slot
slots.private:set-slot
strings.private:string-nth
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
math.private:<complex>
math.private:<ratio>
kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-signed-1
alien.accessors:alien-unsigned-2
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
: enable-alien-4-intrinsics ( -- )
{
alien.accessors:alien-unsigned-4
alien.accessors:set-alien-unsigned-4
alien.accessors:alien-signed-4
alien.accessors:set-alien-signed-4
} [ t "intrinsic" set-word-prop ] each ;
: enable-float-intrinsics ( -- )
{
math.private:float+
math.private:float-
math.private:float*
math.private:float/f
math.private:fixnum>float
math.private:float>fixnum
math.private:float<
math.private:float<=
math.private:float>
math.private:float>=
math.private:float=
alien.accessors:alien-float
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: emit-intrinsic ( node word -- )
{
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ cc= emit-fixnum-comparison ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ math.private:<complex> [ emit-simple-allot ] }
{ \ math.private:<ratio> [ emit-simple-allot ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;

56
basis/compiler/cfg/intrinsics/slots/slots.factor Normal file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.slots
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: value-tag ( info -- n ) class>> class-tag ; inline
: (emit-slot) ( infos -- dst )
[ 2inputs ^^offset>slot ] [ first value-tag ] bi*
^^slot ;
: (emit-slot-imm) ( infos -- dst )
ds-drop
[ ds-pop ]
[ [ second literal>> ] [ first value-tag ] bi ] bi*
^^slot-imm ;
: emit-slot ( node -- )
dup node-input-infos
dup first value-tag [
nip
dup second value-info-small-fixnum?
[ (emit-slot-imm) ] [ (emit-slot) ] if
ds-push
] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs [ tuck ] dip ^^offset>slot ]
[ second value-tag ]
bi* ^^set-slot ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
[ 2inputs tuck ]
[ [ third literal>> ] [ second value-tag ] bi ] bi*
##set-slot-imm ;
: emit-set-slot ( node -- )
dup node-input-infos
dup second value-tag [
nip
[
dup third value-info-small-fixnum?
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
] [ first class>> immediate class<= ] bi
[ drop ] [ i i ##write-barrier ] if
] [ drop emit-primitive ] if ;
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;

3
unfinished/compiler/cfg/iterator/iterator.factor → basis/compiler/cfg/iterator/iterator.factor
View File

@ -19,9 +19,6 @@ SYMBOL: node-stack
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )

145
unfinished/compiler/cfg/linear-scan/allocation/allocation.factor → basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math math.order kernel assocs
accessors vectors fry heaps
accessors vectors fry heaps cpu.architecture combinators
compiler.cfg.registers
compiler.cfg.linear-scan.live-intervals
compiler.backend ;
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation
! Mapping from register classes to sequences of machine registers
@ -19,24 +18,22 @@ SYMBOL: free-registers
! Vector of active live intervals
SYMBOL: active-intervals
: active-intervals-for ( vreg -- seq )
reg-class>> active-intervals get at ;
: add-active ( live-interval -- )
active-intervals get push ;
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
active-intervals get delete ;
dup vreg>> active-intervals-for delq ;
: expire-old-intervals ( n -- )
active-intervals get
swap '[ end>> _ < ] partition
active-intervals set
[ deallocate-register ] each ;
: expire-old-uses ( n -- )
active-intervals get
swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
: update-state ( live-interval -- )
start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
active-intervals swap '[
[
[ end>> _ < ] partition
[ [ deallocate-register ] each ] dip
] assoc-map
] change ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@ -59,14 +56,39 @@ SYMBOL: progress
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;
: assign-free-register ( live-interval registers -- )
#! If the live interval does not have any uses, it means it
#! will be spilled immediately, so it still needs a register
#! to compute the new value, but we don't add the interval
#! to the active set and we don't remove the register from
#! the free list.
over uses>> empty?
[ peek >>reg drop ] [ pop >>reg add-active ] if ;
! Coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: coalesce? ( live-interval -- ? )
[ start>> ] [ copy-from>> active-interval ] bi
dup [ end>> = ] [ 2drop f ] if ;
: coalesce ( live-interval -- )
dup copy-from>> active-interval
[ [ add-active ] [ delete-active ] bi* ]
[ reg>> >>reg drop ]
2bi ;
! Splitting
: find-use ( live-interval n quot -- i elt )
[ uses>> ] 2dip curry find ; inline
: split-before ( live-interval i -- before )
[ clone dup uses>> ] dip
[ head >>uses ] [ 1- swap nth >>end ] 2bi ;
: split-after ( live-interval i -- after )
[ clone dup uses>> ] dip
[ tail >>uses ] [ swap nth >>start ] 2bi
f >>reg f >>copy-from ;
: split-interval ( live-interval n -- before after )
[ drop ] [ [ > ] find-use drop ] 2bi
[ split-before ] [ split-after ] 2bi ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
! Spilling
SYMBOL: spill-counts
@ -74,37 +96,23 @@ SYMBOL: spill-counts
: next-spill-location ( reg-class -- n )
spill-counts get [ dup 1+ ] change-at ;
: interval-to-spill ( -- live-interval )
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
active-intervals get unclip-slice [
[ [ uses>> peek ] bi@ > ] most
] reduce ;
: check-split ( live-interval -- )
[ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
: split-interval ( live-interval -- before after )
#! Split the live interval at the location of its first use.
#! 'Before' now starts and ends on the same instruction.
[ check-split ]
[ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
[ clone f >>reg dup uses>> peek >>start ]
tri ;
: record-split ( live-interval before after -- )
[ >>split-before ] [ >>split-after ] bi* drop ;
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>> [ next-spill-location ] unless*
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
: split-and-spill ( live-interval -- before after )
dup split-interval [ record-split ] [ assign-spill ] 2bi ;
: split-and-spill ( new existing -- before after )
dup rot start>> split-interval
[ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- )
reg>> >>reg
dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
reg>> >>reg add-active ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval
@ -112,41 +120,52 @@ SYMBOL: spill-counts
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
[ nip delete-active ]
[ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
: spill-new ( new existing -- )
#! Our new interval will be used after the active interval
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ split-and-spill add-unhandled ] dip spill-existing ;
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: spill-existing? ( new existing -- ? )
over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
#! Test if 'new' will be used before 'existing'.
over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
: assign-blocked-register ( live-interval -- )
interval-to-spill
2dup spill-existing?
[ spill-existing ] [ spill-new ] if ;
: assign-blocked-register ( new -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill
2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
: assign-register ( live-interval -- )
dup vreg>> free-registers-for [
assign-blocked-register
: assign-free-register ( new registers -- )
pop >>reg add-active ;
: assign-register ( new -- )
dup coalesce? [
coalesce
] [
assign-free-register
] if-empty ;
dup vreg>> free-registers-for
[ assign-blocked-register ]
[ assign-free-register ]
if-empty
] if ;
! Main loop
: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
: init-allocator ( registers -- )
V{ } clone active-intervals set
<min-heap> unhandled-intervals set
[ reverse >vector ] assoc-map free-registers set
H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
reg-classes [ 0 ] { } map>assoc spill-counts set
reg-classes [ V{ } clone ] { } map>assoc active-intervals set
-1 progress set ;
: handle-interval ( live-interval -- )
[ start>> progress set ] [ update-state ] [ assign-register ] tri ;
[ start>> progress set ]
[ start>> expire-old-intervals ]
[ assign-register ]
tri ;
: (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ;

0
unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor → basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

26
unfinished/compiler/cfg/linear-scan/assignment/assignment.factor → basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -2,6 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators
cpu.architecture
compiler.cfg.def-use
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals ;
@ -34,13 +36,8 @@ SYMBOL: unhandled-intervals
[ add-unhandled ] each ;
: insert-spill ( live-interval -- )
[ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
over [
{
{ int-regs [ _spill-integer ] }
{ double-float-regs [ _spill-float ] }
} case
] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
dup [ _spill ] [ 3drop ] if ;
: expire-old-intervals ( n -- )
active-intervals get
@ -49,13 +46,8 @@ SYMBOL: unhandled-intervals
[ insert-spill ] each ;
: insert-reload ( live-interval -- )
[ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
over [
{
{ int-regs [ _reload-integer ] }
{ double-float-regs [ _reload-float ] }
} case
] [ 3drop ] if ;
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
dup [ _reload ] [ 3drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
@ -67,13 +59,17 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if
] if ;
: (assign-registers) ( insn -- )
GENERIC: (assign-registers) ( insn -- )
M: vreg-insn (assign-registers)
dup
[ defs-vregs ] [ uses-vregs ] bi append
active-intervals get swap '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
M: insn (assign-registers) drop ;
: init-assignment ( live-intervals -- )
V{ } clone active-intervals set
<min-heap> unhandled-intervals set

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays
compiler.cfg.linear-scan.live-intervals
USING: accessors kernel sequences sets arrays math strings fry
prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation ;
IN: compiler.cfg.linear-scan.debugger
@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger
: check-linear-scan ( live-intervals machine-registers -- )
[ [ clone ] map ] dip allocate-registers
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
dup peek 1 + CHAR: space <string>
[ '[ CHAR: * swap _ set-nth ] each ] keep ;
: interval-picture ( interval -- str )
[ uses>> picture ]
[ copy-from>> unparse ]
[ vreg>> unparse ]
tri 3array ;
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;

1205
basis/compiler/cfg/linear-scan/linear-scan-tests.factor Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces
compiler.backend
USING: kernel accessors namespaces make
cpu.architecture
compiler.cfg
compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
@ -22,12 +23,16 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' )
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
[
[
dup compute-live-intervals
machine-registers allocate-registers
assign-registers
[
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
spill-counts get >>spill-counts
] with-scope ;

64
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor Normal file
View File

@ -0,0 +1,64 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math fry
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.def-use ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-interval
vreg
reg spill-to reload-from split-before split-after
start end uses
copy-from ;
: add-use ( n live-interval -- )
dup live-interval? [ "No def" throw ] unless
[ (>>end) ] [ uses>> push ] 2bi ;
: <live-interval> ( start vreg -- live-interval )
live-interval new
V{ } clone >>uses
swap >>vreg
over >>start
[ add-use ] keep ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
M: live-interval clone
call-next-method [ clone ] change-uses ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: new-live-interval ( n vreg live-intervals -- )
2dup key? [
at add-use
] [
[ [ <live-interval> ] keep ] dip set-at
] if ;
GENERIC# compute-live-intervals* 1 ( insn n -- )
M: insn compute-live-intervals* 2drop ;
M: vreg-insn compute-live-intervals*
live-intervals get
[ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
[ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
3bi ;
: record-copy ( insn -- )
[ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
M: ##copy compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ;
M: ##copy-float compute-live-intervals*
[ call-next-method ] [ drop record-copy ] 2bi ;
: compute-live-intervals ( instructions -- live-intervals )
H{ } clone [
live-intervals set
[ compute-live-intervals* ] each-index
] keep values ;

4
basis/compiler/cfg/linearization/linearization-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
\ build-mr must-infer

80
basis/compiler/cfg/linearization/linearization.factor Normal file
View File

@ -0,0 +1,80 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences namespaces make
combinators classes
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
: linearize-insns ( basic-block -- )
dup instructions>> [ linearize-insn ] with each ; inline
M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
#! If our successor immediately follows us in RPO, then we
#! don't need to branch.
[ number>> ] bi@ 1- = ; inline
: branch-to-branch? ( successor -- ? )
#! A branch to a block containing just a jump return is cloned.
instructions>> dup length 2 = [
[ first ##epilogue? ]
[ second [ ##return? ] [ ##jump? ] bi or ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-branch? ] [ nip linearize-insns ] }
[ nip number>> _branch ]
} cond ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: (binary-conditional)
[ dup successors>> first2 ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> first useless-branch? ] 2bi
[ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ;
M: ##compare-float-branch linearize-insn
binary-conditional _compare-float-branch emit-branch ;
: gc? ( bb -- ? )
instructions>> [
class {
##allot
##integer>bignum
##box-float
##box-alien
} memq?
] contains? ;
: linearize-basic-block ( bb -- )
[ number>> _label ]
[ gc? [ _gc ] when ]
[ linearize-insns ]
tri ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
: build-mr ( cfg -- mr )
[ entry>> reverse-post-order linearize-basic-blocks ]
[ word>> ] [ label>> ]
tri <mr> ;

29
basis/compiler/cfg/optimizer/optimizer.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.useless-blocks
compiler.cfg.height
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dead-code
compiler.cfg.write-barrier ;
IN: compiler.cfg.optimizer
: trivial? ( insns -- ? )
dup length 2 = [ first ##call? ] [ drop f ] if ;
: optimize-cfg ( cfg -- cfg' )
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
[
dup trivial? [
normalize-height
alias-analysis
value-numbering
eliminate-dead-code
eliminate-write-barriers
] unless
] change-basic-blocks ;

10
basis/compiler/cfg/predecessors/predecessors.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences compiler.cfg.rpo ;
IN: compiler.cfg.predecessors
: (compute-predecessors) ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- cfg' )
dup [ (compute-predecessors) ] each-basic-block ;

37
basis/compiler/cfg/registers/registers.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
TUPLE: vreg { reg-class read-only } { n read-only } ;
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
! Stack locations
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;
C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
: D scan-word <ds-loc> parsed ; parsing
M: ds-loc pprint* \ D pprint-loc ;
: R scan-word <rs-loc> parsed ; parsing
M: rs-loc pprint* \ R pprint-loc ;

32
basis/compiler/cfg/rpo/rpo.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg.instructions ;
IN: compiler.cfg.rpo
SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;
: post-order ( bb -- blocks )
[ post-order-traversal ] { } make ;
: number-blocks ( blocks -- )
[ >>number drop ] each-index ;
: reverse-post-order ( bb -- blocks )
H{ } clone visited [
post-order <reversed> dup number-blocks
] with-variable ; inline
: each-basic-block ( cfg quot -- )
[ entry>> reverse-post-order ] dip each ; inline
: change-basic-blocks ( cfg quot -- cfg' )
[ '[ _ change-instructions drop ] each-basic-block ]
[ drop ]
2bi ; inline

41
unfinished/compiler/cfg/stack-frame/stack-frame.factor → basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,43 +1,45 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
make compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.registers ;
combinators make classes words cpu.architecture
compiler.cfg.instructions compiler.cfg.registers ;
IN: compiler.cfg.stack-frame
SYMBOL: frame-required?
SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
T{ stack-frame } clone stack-frame set ;
GENERIC: compute-stack-frame* ( insn -- )
: max-stack-frame ( frame1 frame2 -- frame3 )
{
[ [ size>> ] bi@ max ]
[ [ params>> ] bi@ max ]
[ [ return>> ] bi@ max ]
[ [ total-size>> ] bi@ max ]
} cleave
stack-frame boa ;
[ stack-frame new ] 2dip
[ [ params>> ] bi@ max >>params ]
[ [ return>> ] bi@ max >>return ]
2bi ;
M: ##stack-frame compute-stack-frame*
frame-required? on
stack-frame>> stack-frame [ max-stack-frame ] change ;
M: _spill-integer compute-stack-frame*
drop frame-required? on ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: _spill-float compute-stack-frame*
drop frame-required? on ;
M: _spill-counts compute-stack-frame*
counts>> stack-frame get (>>spill-counts) ;
M: insn compute-stack-frame* drop ;
M: insn compute-stack-frame*
class frame-required? word-prop [
frame-required? on
] when ;
\ _gc t frame-required? set-word-prop
\ _spill t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
[ compute-stack-frame* ] each ;
frame-required? off
T{ stack-frame } clone stack-frame set
[ compute-stack-frame* ] each
stack-frame get dup stack-frame-size >>total-size drop ;
GENERIC: insert-pro/epilogues* ( insn -- )
@ -56,7 +58,6 @@ M: insn insert-pro/epilogues* , ;
: build-stack-frame ( mr -- mr )
[
init-stack-frame-builder
[
[ compute-stack-frame ]
[ insert-pro/epilogues ]

0
basis/compiler/generator/fixup/authors.txt → basis/compiler/cfg/stacks/authors.txt
View File

33
basis/compiler/cfg/stacks/stacks.factor Executable file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel cpu.architecture
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.hats ;
IN: compiler.cfg.stacks
: ds-drop ( -- )
-1 ##inc-d ;
: ds-pop ( -- vreg )
D 0 ^^peek -1 ##inc-d ;
: ds-push ( vreg -- )
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
: ds-store ( vregs -- )
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
: rs-load ( n -- vregs )
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
: rs-store ( vregs -- )
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
: 3inputs ( -- vreg1 vreg2 vreg3 )
D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;

60
basis/compiler/cfg/two-operand/two-operand.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences sequences.deep
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z
! We don't bother with ##add, ##add-imm or ##sub-imm since x86
! has a LEA instruction which is effectively a three-operand
! addition
: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
: convert-two-operand/integer ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy ]
[ dup dst>> >>src1 ]
bi 2array ; inline
: convert-two-operand/float ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy/float ]
[ dup dst>> >>src1 ]
bi 2array ; inline
GENERIC: convert-two-operand* ( insn -- insns )
M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ]
[ dup dst>> >>src ]
bi 2array ;
M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul convert-two-operand* convert-two-operand/integer ;
M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
M: ##and convert-two-operand* convert-two-operand/integer ;
M: ##and-imm convert-two-operand* convert-two-operand/integer ;
M: ##or convert-two-operand* convert-two-operand/integer ;
M: ##or-imm convert-two-operand* convert-two-operand/integer ;
M: ##xor convert-two-operand* convert-two-operand/integer ;
M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
M: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-float convert-two-operand* convert-two-operand/float ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;
M: ##div-float convert-two-operand* convert-two-operand/float ;
M: insn convert-two-operand* ;
: convert-two-operand ( mr -- mr' )
[
two-operand? [
[ convert-two-operand* ] map flatten
] when
] change-instructions ;

55
basis/compiler/cfg/useless-blocks/useless-blocks.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators classes vectors
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
IN: compiler.cfg.useless-blocks
: update-predecessor-for-delete ( bb -- )
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] with map
] change-successors drop ;
: update-successor-for-delete ( bb -- )
[ predecessors>> first ]
[ successors>> first predecessors>> ]
bi set-first ;
: delete-basic-block ( bb -- )
[ update-predecessor-for-delete ]
[ update-successor-for-delete ]
bi ;
: delete-basic-block? ( bb -- ? )
{
{ [ dup instructions>> length 1 = not ] [ f ] }
{ [ dup predecessors>> length 1 = not ] [ f ] }
{ [ dup successors>> length 1 = not ] [ f ] }
{ [ dup instructions>> first ##branch? not ] [ f ] }
[ t ]
} cond nip ;
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
peek class {
##compare-branch
##compare-imm-branch
##compare-float-branch
} memq? [ successors>> first2 eq? ] [ drop f ] if
] if-empty ;
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block ;

37
basis/compiler/cfg/utilities/utilities.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
: end-basic-block ( -- )
building off
basic-block off ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;

88
basis/compiler/cfg/value-numbering/expressions/expressions.factor Normal file
View File

@ -0,0 +1,88 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes kernel math namespaces combinators
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions
TUPLE: expr op ;
TUPLE: unary-expr < expr in ;
TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
: <constant> ( constant -- expr )
f swap constant-expr boa ; inline
M: constant-expr equal?
over constant-expr? [
[ [ value>> ] bi@ = ]
[ [ value>> class ] bi@ = ] 2bi
and
] [ 2drop f ] if ;
SYMBOL: input-expr-counter
: next-input-expr ( -- n )
input-expr-counter [ dup 1 + ] change ;
! Expressions whose values are inputs to the basic block. We
! can eliminate a second computation having the same 'n' as
! the first one; we can also eliminate input-exprs whose
! result is not used.
TUPLE: input-expr < expr n ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )
M: ##load-immediate >expr val>> <constant> ;
M: ##load-indirect >expr obj>> <constant> ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
M: ##binary >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
binary-expr boa ;
M: ##binary-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
binary-expr boa ;
M: ##commutative >expr
[ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
commutative-expr boa ;
M: ##commutative-imm >expr
[ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
commutative-expr boa ;
: compare>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
M: ##compare >expr compare>expr ;
: compare-imm>expr ( insn -- expr )
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> constant>vn ]
[ cc>> ]
} cleave compare-expr boa ; inline
M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>expr ;
M: ##flushable >expr class next-input-expr input-expr boa ;
: init-expressions ( -- )
0 input-expr-counter set ;

19
unfinished/compiler/cfg.bluesky/vn/graph/graph.factor → basis/compiler/cfg/value-numbering/graph/graph.factor
View File

@ -1,20 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs biassocs accessors
math.order prettyprint.backend parser ;
IN: compiler.cfg.vn.graph
TUPLE: vn n ;
USING: accessors kernel math namespaces assocs biassocs ;
IN: compiler.cfg.value-numbering.graph
SYMBOL: vn-counter
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
: VN: scan-word vn boa parsed ; parsing
M: vn <=> [ n>> ] compare ;
M: vn pprint* \ VN: pprint-word n>> pprint* ;
: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
@ -31,6 +22,10 @@ SYMBOL: vregs>vns
: set-vn ( vn vreg -- ) vregs>vns get set-at ;
: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
: vn>constant ( vn -- constant ) vn>expr value>> ; inline
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set

65
basis/compiler/cfg/value-numbering/propagate/propagate.factor Normal file
View File

@ -0,0 +1,65 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sequences kernel accessors
compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.propagate
! If two vregs compute the same value, replace references to
! the latter with the former.
: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
GENERIC: propagate ( insn -- insn )
M: ##effect propagate
[ resolve ] change-src ;
M: ##unary propagate
[ resolve ] change-src ;
M: ##binary propagate
[ resolve ] change-src1
[ resolve ] change-src2 ;
M: ##binary-imm propagate
[ resolve ] change-src1 ;
M: ##slot propagate
[ resolve ] change-obj
[ resolve ] change-slot ;
M: ##slot-imm propagate
[ resolve ] change-obj ;
M: ##set-slot propagate
call-next-method
[ resolve ] change-obj
[ resolve ] change-slot ;
M: ##string-nth propagate
[ resolve ] change-obj
[ resolve ] change-index ;
M: ##set-slot-imm propagate
call-next-method
[ resolve ] change-obj ;
M: ##alien-getter propagate
call-next-method
[ resolve ] change-src ;
M: ##alien-setter propagate
call-next-method
[ resolve ] change-value ;
M: ##conditional-branch propagate
[ resolve ] change-src1
[ resolve ] change-src2 ;
M: ##compare-imm-branch propagate
[ resolve ] change-src1 ;
M: ##dispatch propagate
[ resolve ] change-src ;
M: insn propagate ;

116
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor Normal file
View File

@ -0,0 +1,116 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' )
M: ##mul-imm rewrite
dup src2>> dup power-of-2? [
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
dup number-values
] [ drop ] if ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
[ cc>> cc/= eq? ]
[ src2>> \ f tag-number eq? ] bi and
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
src1>> vreg>expr compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
[ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
} case ;
: tag-fixnum-expr? ( expr -- ? )
dup op>> \ ##shl-imm eq?
[ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
[ src1>> vreg>expr tag-fixnum-expr? ]
[ src2>> tag-mask get bitand 0 = ]
bi and ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ cc>> ]
tri ; inline
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
dup ##compare-imm-branch? [
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
: flip-comparison? ( insn -- ? )
dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
: flip-comparison ( insn -- insn' )
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
flip-comparison
dup number-values
rewrite
] when ;
: rewrite-redundant-comparison? ( insn -- ? )
[ src1>> vreg>expr compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
tri and and ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
M: ##compare-imm rewrite
dup rewrite-redundant-comparison? [
rewrite-redundant-comparison
dup number-values rewrite
] when
dup ##compare-imm? [
dup rewrite-tagged-comparison? [
rewrite-tagged-comparison
dup number-values rewrite
] when
] when ;
M: insn rewrite ;

74
basis/compiler/cfg/value-numbering/simplify/simplify.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
: simplify-unbox ( in boxer -- vn/expr/f )
over op>> eq? [ in>> ] [ drop f ] if ; inline
: simplify-unbox-float ( in -- vn/expr/f )
\ ##box-float simplify-unbox ; inline
: simplify-unbox-alien ( in -- vn/expr/f )
\ ##box-alien simplify-unbox ; inline
M: unary-expr simplify*
#! Note the copy propagation: a copy always simplifies to
#! its source VN.
[ in>> vn>expr ] [ op>> ] bi {
{ \ ##copy [ ] }
{ \ ##copy-float [ ] }
{ \ ##unbox-float [ simplify-unbox-float ] }
{ \ ##unbox-alien [ simplify-unbox-alien ] }
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
[ 2drop f ]
} case ;
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: useless-shift? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shift ( expr -- vn/expr/f )
>binary-expr<
2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
M: binary-expr simplify*
dup op>> {
{ \ ##add [ simplify-add ] }
{ \ ##add-imm [ simplify-add ] }
{ \ ##shr-imm [ simplify-shift ] }
{ \ ##sar-imm [ simplify-shift ] }
[ 2drop f ]
} case ;
M: expr simplify* drop f ;
: simplify ( expr -- vn )
dup simplify* {
{ [ dup not ] [ drop expr>vn ] }
{ [ dup expr? ] [ expr>vn nip ] }
{ [ dup integer? ] [ nip ] }
} cond ;
GENERIC: number-values ( insn -- )
M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
M: insn number-values drop ;

142
basis/compiler/cfg/value-numbering/value-numbering-tests.factor Normal file
View File

@ -0,0 +1,142 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math ;
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
}
] [
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering
] unit-test
[
{
T{ ##load-immediate f V int-regs 2 8 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
}
] [
{
T{ ##load-immediate f V int-regs 2 8 }
T{ ##peek f V int-regs 3 D 0 }
T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
T{ ##replace f V int-regs 4 D 0 }
} value-numbering
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 }
} dup value-numbering =
] unit-test
[ t ] [
{
T{ ##peek f V int-regs 16 D 0 }
T{ ##peek f V int-regs 17 D -1 }
T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
T{ ##replace f V int-regs 23 D 0 }
} dup value-numbering =
] unit-test
[
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 1 D 0 }
}
] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
T{ ##replace f V int-regs 3 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 4 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 6 D 0 }
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
T{ ##replace f V int-regs 14 D 0 }
}
] [
{
T{ ##peek f V int-regs 8 D 0 }
T{ ##peek f V int-regs 9 D -1 }
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering
] unit-test
[
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
}
] [
{
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering
] unit-test

15
basis/compiler/cfg/value-numbering/value-numbering.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
: value-numbering ( insns -- insns' )
init-value-graph
init-expressions
[ [ number-values ] [ rewrite propagate ] bi ] map ;

72
basis/compiler/cfg/write-barrier/write-barrier-tests.factor Normal file
View File

@ -0,0 +1,72 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers cpu.architecture arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[
{
T{ ##peek f V int-regs 4 D 0 f }
T{ ##copy f V int-regs 6 V int-regs 4 f }
T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
T{ ##load-immediate f V int-regs 9 8 f }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
T{ ##replace f V int-regs 7 D 0 f }
}
] [
{
T{ ##peek f V int-regs 4 D 0 }
T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##allot f V int-regs 7 24 array V int-regs 8 }
T{ ##load-immediate f V int-regs 9 8 }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
} eliminate-write-barriers
] unit-test
[
{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
}
] [
{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
} eliminate-write-barriers
] unit-test
[
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
}
] [
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
} eliminate-write-barriers
] unit-test

42
basis/compiler/cfg/write-barrier/write-barrier.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
! Objects which have already been marked, as well as
! freshly-allocated objects
SYMBOL: safe
! Objects which have been mutated
SYMBOL: mutated
GENERIC: eliminate-write-barrier ( insn -- insn' )
M: ##allot eliminate-write-barrier
dup dst>> safe get conjoin ;
M: ##write-barrier eliminate-write-barrier
dup src>> resolve dup
[ safe get key? not ]
[ mutated get key? ] bi and
[ safe get conjoin ] [ 2drop f ] if ;
M: ##copy eliminate-write-barrier
dup record-copy ;
M: ##set-slot eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
M: ##set-slot-imm eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
M: insn eliminate-write-barrier ;
: eliminate-write-barriers ( insns -- insns' )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;

309
unfinished/compiler/codegen/codegen.factor → basis/compiler/codegen/codegen.factor
View File

@ -1,30 +1,28 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.parser sequences accessors
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 sets threads libc continuations.private
alien.strings alien.arrays sets threads libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
compiler.backend
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder ;
compiler.cfg.builder
compiler.codegen.fixup ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
GENERIC: v>operand ( obj -- operand )
SYMBOL: registers
M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
: register ( vreg -- operand )
registers get at [ "Bad value" throw ] unless* ;
M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
: ?register ( obj -- operand )
dup vreg? [ register ] when ;
: generate-insns ( insns -- code )
[
@ -68,118 +66,156 @@ SYMBOL: labels
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
M: _label generate-insn
id>> lookup-label , ;
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
M: _prologue generate-insn
stack-frame>>
[ stack-frame set ]
[ dup size>> stack-frame-size >>total-size drop ]
[ total-size>> %prologue ]
tri ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
M: ##load-indirect generate-insn
[ dst>> register ] [ obj>> ] bi %load-indirect ;
M: ##peek generate-insn
[ dst>> v>operand ] [ loc>> ] bi %peek ;
[ dst>> register ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
[ src>> ] [ loc>> ] bi %replace ;
[ src>> register ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##inc-r generate-insn n>> %inc-r ;
M: ##return generate-insn drop %return ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
SYMBOL: operands
: init-intrinsic ( insn -- )
[ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
M: ##intrinsic generate-insn
[ init-intrinsic ] [ quot>> call ] bi ;
: (operand) ( name -- operand )
operands get at* [ "Bad operand name" throw ] unless ;
: operand ( name -- operand )
(operand) v>operand ;
: operand-class ( var -- class )
(operand) value-class ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
M: _if-intrinsic generate-insn
[ init-intrinsic ]
[ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
M: _branch-f generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
M: _branch-t generate-insn
[ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn drop %dispatch ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
: >slot<
{
[ dst>> register ]
[ obj>> register ]
[ slot>> ?register ]
[ tag>> ]
} cleave ; inline
M: ##slot generate-insn
[ >slot< ] [ temp>> register ] bi %slot ;
M: ##slot-imm generate-insn
>slot< %slot-imm ;
: >set-slot<
{
[ src>> register ]
[ obj>> register ]
[ slot>> ?register ]
[ tag>> ]
} cleave ; inline
M: ##set-slot generate-insn
[ >set-slot< ] [ temp>> register ] bi %set-slot ;
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
M: ##string-nth generate-insn
{
[ dst>> register ]
[ obj>> register ]
[ index>> register ]
[ temp>> register ]
} cleave %string-nth ;
: dst/src ( insn -- dst src )
[ dst>> v>operand ] [ src>> v>operand ] bi ;
[ dst>> register ] [ src>> register ] bi ; inline
M: ##copy generate-insn dst/src %copy ;
: dst/src1/src2 ( insn -- dst src1 src2 )
[ dst>> register ]
[ src1>> register ]
[ src2>> ?register ] tri ; inline
M: ##copy-float generate-insn dst/src %copy-float ;
M: ##add generate-insn dst/src1/src2 %add ;
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
M: ##sub generate-insn dst/src1/src2 %sub ;
M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
M: ##mul generate-insn dst/src1/src2 %mul ;
M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
M: ##and generate-insn dst/src1/src2 %and ;
M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
M: ##or generate-insn dst/src1/src2 %or ;
M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
M: ##xor generate-insn dst/src1/src2 %xor ;
M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
M: ##unbox-f generate-insn dst/src %unbox-f ;
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
M: ##unbox-alien generate-insn dst/src %unbox-alien ;
M: ##add-float generate-insn dst/src1/src2 %add-float ;
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
M: ##div-float generate-insn dst/src1/src2 %div-float ;
M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
M: ##copy generate-insn dst/src %copy ;
M: ##copy-float generate-insn dst/src %copy-float ;
M: ##unbox-float generate-insn dst/src %unbox-float ;
M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-float generate-insn dst/src %box-float ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
M: ##alien-cell generate-insn dst/src %alien-cell ;
M: ##alien-float generate-insn dst/src %alien-float ;
M: ##alien-double generate-insn dst/src %alien-double ;
M: ##box-alien generate-insn dst/src %box-alien ;
: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
M: ##allot generate-insn
{
[ dst>> v>operand ]
[ dst>> register ]
[ size>> ]
[ type>> ]
[ tag>> ]
[ temp>> v>operand ]
[ class>> ]
[ temp>> register ]
} cleave
%allot ;
M: ##write-barrier generate-insn
[ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
[ src>> register ]
[ card#>> register ]
[ table>> register ]
tri %write-barrier ;
M: ##gc generate-insn drop %gc ;
M: _gc generate-insn drop %gc ;
! #alien-invoke
M: ##loop-entry generate-insn drop %loop-entry ;
! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@ -188,6 +224,8 @@ M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
@ -196,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
M: reg-class inc-reg-class
dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
: ?dummy-stack-params ( reg-class -- )
dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( reg-class -- )
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
: ?dummy-fp-params ( reg-class -- )
drop dummy-fp-params? [ float-regs inc ] when ;
M: int-regs inc-reg-class
[ reg-class-variable inc ]
[ ?dummy-stack-params ]
[ ?dummy-fp-params ]
tri ;
M: float-regs inc-reg-class
dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
[ reg-class-variable inc ]
[ ?dummy-stack-params ]
[ ?dummy-int-params ]
tri ;
GENERIC: reg-class-full? ( class -- ? )
@ -268,7 +319,7 @@ M: long-long-type flatten-value-type ( type -- types )
>r
alien-parameters
flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
r> '[ alloc-parameter _ execute ] each-parameter ;
inline
: unbox-parameters ( offset node -- )
@ -323,7 +374,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
dupd '[ _ dlsym ] contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
@ -399,7 +450,7 @@ TUPLE: callback-context ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ c-type c-type-unboxer-quot ]
} cond ;
@ -416,23 +467,69 @@ TUPLE: callback-context ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( params -- n )
{
{ [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
: %callback-return ( params -- )
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup alien-return
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
params>> %callback-return ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
M: _prologue generate-insn
stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
M: _epilogue generate-insn
stack-frame>> total-size>> %epilogue ;
M: _label generate-insn
id>> lookup-label , ;
M: _branch generate-insn
label>> lookup-label %jump-label ;
: >compare< ( insn -- label cc src1 src2 )
{
[ dst>> register ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]
} cleave ; inline
M: ##compare generate-insn >compare< %compare ;
M: ##compare-imm generate-insn >compare< %compare-imm ;
M: ##compare-float generate-insn >compare< %compare-float ;
: >binary-branch< ( insn -- label cc src1 src2 )
{
[ label>> lookup-label ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]
} cleave ; inline
M: _compare-branch generate-insn
>binary-branch< %compare-branch ;
M: _compare-imm-branch generate-insn
>binary-branch< %compare-imm-branch ;
M: _compare-float-branch generate-insn
>binary-branch< %compare-float-branch ;
M: _spill generate-insn
[ src>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %spill-integer ] }
{ double-float-regs [ %spill-float ] }
} case ;
M: _reload generate-insn
[ dst>> ] [ n>> ] [ class>> ] tri {
{ int-regs [ %reload-integer ] }
{ double-float-regs [ %reload-float ] }
} case ;
M: _spill-counts generate-insn drop ;

0
basis/compiler/generator/registers/authors.txt → basis/compiler/codegen/fixup/authors.txt
View File

7
unfinished/compiler/codegen/fixup/fixup.factor → basis/compiler/codegen/fixup/fixup.factor
View File

@ -4,7 +4,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable compiler.constants compiler.backend ;
growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
@ -43,9 +43,10 @@ M: rel-fixup fixup*
M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table

0
basis/compiler/generator/fixup/summary.txt → basis/compiler/codegen/fixup/summary.txt
View File

5
basis/compiler/compiler-docs.factor
View File

@ -1,4 +1,4 @@
USING: compiler.generator help.markup help.syntax words io parser
USING: help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
@ -27,8 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
{ $subsection "compiler-usage" }
{ $subsection "compiler-errors" }
{ $subsection "hints" }
{ $subsection "generator" } ;
{ $subsection "hints" } ;
ABOUT: "compiler"

80
basis/compiler/compiler.factor
View File

@ -1,12 +1,32 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io debugger words fry
compiler.units continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
stack-checker stack-checker.state compiler.generator
compiler.errors compiler.tree.builder compiler.tree.optimizer ;
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
: ripple-up ( words -- )
@ -24,10 +44,13 @@ SYMBOL: +failed+
[ "compiled-effect" set-word-prop ]
2bi ;
: compile-begins ( word -- )
: start ( word -- )
"trace-compilation" get [ dup . flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
: compile-failed ( word error -- )
: fail ( word error -- )
[ swap compiler-error ]
[
drop
@ -35,9 +58,34 @@ SYMBOL: +failed+
[ f swap compiled get set-at ]
[ +failed+ save-effect ]
tri
] 2bi ;
] 2bi
return ;
: compile-succeeded ( effect word -- )
: frontend ( word -- effect nodes )
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
bi ;
: backend ( nodes word -- )
build-cfg [
optimize-cfg
build-mr
convert-two-operand
linear-scan
build-stack-frame
generate
save-asm
] each ;
: finish ( effect word -- )
[ swap save-effect ]
[ compiled-unxref ]
[
@ -51,17 +99,11 @@ SYMBOL: +failed+
: (compile) ( word -- )
'[
H{ } clone dependencies set
H{ } clone generic-dependencies set
_ {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover
optimize-tree
]
[ dup generate ]
[ compile-succeeded ]
[ start ]
[ frontend ]
[ backend ]
[ finish ]
} cleave
] with-return ;

71
basis/compiler/constants/constants.factor
View File

@ -1,49 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system ;
USING: math kernel layouts system strings ;
IN: compiler.constants
! These constants must match vm/memory.h
: card-bits 8 ;
: deck-bits 18 ;
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
: card-bits 8 ; inline
: deck-bits 18 ; inline
: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ;
: float-offset ( -- n ) 8 float tag-number - ;
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute-cell 0 ; inline
: rc-absolute 1 ; inline
: rc-relative 2 ; inline
: rc-absolute-ppc-2/2 3 ; inline
: rc-relative-ppc-2 4 ; inline
: rc-relative-ppc-3 5 ; inline
: rc-relative-arm-3 6 ; inline
: rc-indirect-arm 7 ; inline
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

19
basis/compiler/generator/fixup/fixup-docs.factor
View File

@ -1,19 +0,0 @@
USING: help.syntax help.markup math kernel
words strings alien compiler.generator ;
IN: compiler.generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
HELP: rel-dlsym
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
} ;
HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;

154
basis/compiler/generator/fixup/fixup.factor
View File

@ -1,154 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.generator.fixup
: no-stack-frame -1 ; inline
TUPLE: frame-required n ;
: frame-required ( n -- ) \ frame-required boa , ;
: compute-stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
GENERIC: fixup* ( frame-size obj -- frame-size )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
TUPLE: label offset ;
: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset >>offset drop ;
: define-label ( name -- ) <label> swap set ;
: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
[ 2drop ] [ stack-frame-size swap call ] if ; inline
M: word fixup*
{
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
SYMBOL: label-table
! Relocation classes
: rc-absolute-cell 0 ;
: rc-absolute 1 ;
: rc-relative 2 ;
: rc-absolute-ppc-2/2 3 ;
: rc-relative-ppc-2 4 ;
: rc-relative-ppc-3 5 ;
: rc-relative-arm-3 6 ;
: rc-indirect-arm 7 ;
: rc-indirect-arm-pc 8 ;
: rc-absolute? ( n -- ? )
dup rc-absolute-cell =
over rc-absolute =
rot rc-absolute-ppc-2/2 = or or ;
! Relocation types
: rt-primitive 0 ;
: rt-dlsym 1 ;
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
: rt-immediate 7 ;
TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
dup label>> swap class>> compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
: rel-dlsym ( name dll class -- )
>r literal-table get length >r
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
: rel-word ( word class -- )
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
[
first3 offset>>
[ "Unresolved label" throw ] unless*
3array
] map concat ;
: fixup ( code -- literals relocation labels code )
[
init-fixup
dup compute-stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
] { } make ;

85
basis/compiler/generator/generator-docs.factor
View File

@ -1,85 +0,0 @@
USING: help.markup help.syntax words debugger
compiler.generator.fixup compiler.generator.registers quotations
kernel vectors arrays effects sequences ;
IN: compiler.generator
ARTICLE: "generator" "Compiled code generator"
"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
$nl
"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
{ $subsection compiled-stack-traces? }
"Assembler intrinsics can be defined for low-level optimization:"
{ $subsection define-intrinsic }
{ $subsection define-intrinsics }
{ $subsection define-if-intrinsic }
{ $subsection define-if-intrinsics }
"The main entry point into the code generator:"
{ $subsection generate } ;
ABOUT: "generator"
HELP: compiled
{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
HELP: compiling-word
{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiling-label
{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
HELP: compiled-stack-traces?
{ $values { "?" "a boolean" } }
{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
HELP: begin-compiling
{ $values { "word" word } { "label" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: with-generator
{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
HELP: generate-node
{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate-nodes
{ $values { "nodes" "a sequence of nodes" } }
{ $description "Recursively generate machine code for a dataflow graph." }
{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
HELP: generate
{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
HELP: define-intrinsics
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
$nl
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
HELP: define-intrinsic
{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
$nl
"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
HELP: if>boolean-intrinsic
{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
HELP: define-if-intrinsics
{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
$nl
"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
$nl
"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
HELP: define-if-intrinsic
{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
$nl
"See " { $link define-if-intrinsics } " for a description of the parameters." } ;

581
basis/compiler/generator/generator.factor
View File

@ -1,581 +0,0 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
kernel.private layouts math math.parser namespaces make
prettyprint quotations sequences system threads words vectors
sets deques continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining compiler.tree compiler.tree.builder
compiler.tree.combinators compiler.tree.propagation.info
compiler.generator.fixup compiler.generator.registers
compiler.generator.iterator ;
IN: compiler.generator
SYMBOL: compile-queue
SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word
SYMBOL: compiling-label
SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 59 getenv ;
: begin-compiling ( word label -- )
H{ } clone compiling-loops set
compiling-label set
compiling-word set
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
f compiling-label get compiled get set-at ;
: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( nodes word label quot -- )
[
>r begin-compiling r>
{ } make fixup
save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
: generate-nodes ( nodes -- )
[ current-node generate-node ] iterate-nodes
end-basic-block ;
: init-generate-nodes ( -- )
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( nodes word label -- )
[
init-generate-nodes
[ generate-nodes ] with-node-iterator
] with-generator ;
: intrinsics ( #call -- quot )
word>> "intrinsics" word-prop ;
: if-intrinsics ( #call -- quot )
word>> "if-intrinsics" word-prop ;
! node
M: node generate-node drop iterate-next ;
: %jump ( word -- )
dup compiling-label get eq?
[ drop current-label-start get ] [ %epilogue-later ] if
%jump-label ;
: generate-call ( label -- next )
dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
] [
tail-call? [
%jump f
] [
0 frame-required
%call
iterate-next
] if
] ?if ;
! #recursive
: compile-recursive ( node -- next )
dup label>> id>> generate-call >r
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
r> ;
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
: compile-loop ( node -- next )
end-basic-block
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
iterate-next ;
M: #recursive generate-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
: end-false-branch ( label -- )
tail-call? [ %return drop ] [ %jump-label ] if ;
: generate-branch ( nodes -- )
[ copy-templates generate-nodes ] with-scope ;
: generate-if ( node label -- next )
<label> [
>r >r children>> first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
[ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
! #dispatch
: dispatch-branch ( nodes word -- label )
gensym [
[
copy-templates
%save-dispatch-xt
%prologue-later
[ generate-nodes ] with-node-iterator
%return
] with-generator
] keep ;
: dispatch-branches ( node -- )
children>> [
compiling-word get dispatch-branch
%dispatch-label
] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
generate-dispatch iterate-next
] [
compiling-word get gensym [
[
init-generate-nodes
generate-dispatch
] with-generator
] keep generate-call
] if ;
! #call
: define-intrinsics ( word intrinsics -- )
"intrinsics" set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if>branch-intrinsics ( word intrinsics -- )
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
"false" define-label
"end" define-label
"false" get swap call
t "if-scratch" get load-literal
"end" get %jump-label
"false" resolve-label
f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
{ { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )
[ +input+ associate ] assoc-map
2dup define-if>branch-intrinsics
define-if>boolean-intrinsics ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( pair -- next )
<label> [ swap do-template skip-next ] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
{ [ dup length 2 < ] [ 2drop f ] }
{ [ dup second #if? ] [ drop if-intrinsics find-template ] }
[ 2drop f ]
} cond ;
M: #call generate-node
dup node-input-infos [ class>> ] map set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [
dup find-intrinsic [
do-template iterate-next
] [
word>> generate-call
] ?if
] ?if ;
! #call-recursive
M: #call-recursive generate-node label>> id>> generate-call ;
! #push
M: #push generate-node
literal>> <constant> phantom-push iterate-next ;
! #shuffle
M: #shuffle generate-node
shuffle-effect phantom-shuffle iterate-next ;
M: #>r generate-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ phantom-drop ] [ phantom->r ] if
iterate-next ;
M: #r> generate-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ phantom-rdrop ] [ phantom-r> ] if
iterate-next ;
! #return
M: #return generate-node
drop end-basic-block %return f ;
M: #return-recursive generate-node
end-basic-block
label>> id>> compiling-loops get key?
[ %return ] unless f ;
! #alien-invoke
: large-struct? ( ctype -- ? )
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
swap return>> large-struct? [ "void*" prefix ] when ;
: alien-return ( params -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r c-type-stack-align align dup r> - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.
[
0 [
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
: alien-stack-frame ( params -- n )
stack-frame new
swap
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi
dup [ params>> ] [ return>> ] bi + >>size
dup size>> stack-frame-size >>total-size ;
: with-stack-frame ( params quot -- )
swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
call
stack-frame off ; inline
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
M: stack-params reg-size drop "void*" heap-size ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
M: stack-params reg-class-variable drop stack-params ;
GENERIC: inc-reg-class ( register-class -- )
M: reg-class inc-reg-class
dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: float-regs inc-reg-class
dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
[ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- types )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
#! Convert value type structs to consecutive void*s.
[
0 [
c-type
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type %
] reduce drop
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
: reset-freg-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-freg-counts call ] with-scope ; inline
: move-parameters ( node word -- )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
>r
alien-parameters
flatten-value-types
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
inline
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
: prepare-box-struct ( node -- offset )
#! Return offset on C stack where to store unboxed
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
return>> large-struct?
[ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
#! generate code for moving these parameters to register on
#! architectures where parameters are passed in registers.
[
[ prepare-box-struct ] keep
[ unbox-parameters ] keep
\ %load-param-reg move-parameters
] with-param-regs ;
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
TUPLE: no-such-library name ;
M: no-such-library summary
drop "Library not found" ;
M: no-such-library compiler-error-type
drop +linkage+ ;
: no-such-library ( name -- )
\ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
M: no-such-symbol summary
drop "Symbol not found" ;
M: no-such-symbol compiler-error-type
drop +linkage+ ;
: no-such-symbol ( name -- )
\ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd [ dlsym ] curry contains?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop
] if ;
: stdcall-mangle ( symbol node -- symbol )
"@"
swap parameters>> parameter-sizes drop
number>string 3append ;
: alien-invoke-dlsym ( params -- symbols dll )
dup function>> dup pick stdcall-mangle 2array
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
M: #alien-invoke generate-node
params>>
dup [
end-basic-block
%prepare-alien-invoke
dup objects>registers
%prepare-var-args
dup alien-invoke-dlsym %alien-invoke
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-indirect
M: #alien-indirect generate-node
params>>
dup [
! Flush registers
end-basic-block
! Save registers for GC
%prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
dup %cleanup
box-return*
iterate-next
] with-stack-frame ;
! #alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
: registers>objects ( node -- )
[
dup \ %save-param-reg move-parameters
"nest_stacks" f %alien-invoke
box-parameters
] with-param-regs ;
TUPLE: callback-context ;
: current-callback 2 getenv ;
: wait-to-return ( token -- )
dup current-callback eq? [
drop
] [
yield wait-to-return
] if ;
: do-callback ( quot token -- )
init-catchstack
dup 2 setenv
slip
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
[ c-type c-type-unboxer-quot ]
} cond ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[
[ callback-prep-quot ]
[ quot>> ]
[ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( params -- n )
{
{ [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
: %callback-return ( params -- )
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
dup alien-return
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
: generate-callback ( params -- )
dup xt>> dup [
init-templates
%prologue-later
dup [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-generator ;
M: #alien-callback generate-node
end-basic-block
params>> generate-callback iterate-next ;

45
basis/compiler/generator/iterator/iterator.factor
View File

@ -1,45 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences kernel compiler.tree ;
IN: compiler.generator.iterator
SYMBOL: node-stack
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
: node@ ( -- cursor ) node-stack get peek ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
: iterate-nodes ( cursor quot: ( -- ) -- )
over empty? [
2drop
] [
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
>r V{ } clone node-stack r> with-variable ; inline
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
[ t ] [
[ first [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
] if-empty ;
: tail-call? ( -- ? )
node-stack get [
rest-slice
[ t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] if-empty
] all? ;

672
basis/compiler/generator/registers/registers.factor
View File

@ -1,672 +0,0 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private classes.algebra
combinators hashtables kernel layouts math namespaces make
quotations sequences system vectors words effects alien
byte-arrays accessors sets math.order cpu.architecture
compiler.generator.fixup ;
IN: compiler.generator.registers
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
<PRIVATE
! Value protocol
GENERIC: set-operand-class ( class obj -- )
GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-vregs* ( obj -- )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: %move
MIXIN: value
PRIVATE>
: operand-class ( operand -- class )
operand-class* object or ;
! Default implementation
M: value set-operand-class 2drop ;
M: value operand-class* drop f ;
M: value live-vregs* drop ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
TUPLE: vreg n reg-class ;
C: <vreg> vreg ( n reg-class -- vreg )
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
M: vreg move-spec
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
M: vreg operand-class*
reg-class>> {
{ [ dup int-regs? ] [ f ] }
{ [ dup float-regs? ] [ float ] }
} cond nip ;
INSTANCE: vreg value
! Temporary register for stack shuffling
SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
M: loc operand-class* class>> ;
M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ;
INSTANCE: loc value
M: f move-spec drop loc ;
M: f operand-class* ;
! A stack location which has been loaded into a register. To
! read the location, we just read the register, but when time
! comes to save it back to the stack, we know the register just
! contains a stack value so we don't have to redundantly write
! it back.
TUPLE: cached loc vreg ;
C: <cached> cached
M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-vregs* vreg>> live-vregs* ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached lazy-store
2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
INSTANCE: cached value
! A tagged pointer
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
f tagged boa ;
M: tagged v>operand vreg>> v>operand ;
M: tagged set-operand-class (>>class) ;
M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
M: tagged live-vregs* vreg>> , ;
INSTANCE: tagged value
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
M: unboxed-alien v>operand vreg>> v>operand ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
M: unboxed-alien live-vregs* vreg>> , ;
INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand vreg>> v>operand ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-byte-array live-vregs* vreg>> , ;
INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
M: unboxed-f v>operand vreg>> v>operand ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
M: unboxed-f live-vregs* vreg>> , ;
INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand vreg>> v>operand ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: unboxed-c-ptr live-vregs* vreg>> , ;
INSTANCE: unboxed-c-ptr value
! A constant value
TUPLE: constant value ;
C: <constant> constant
M: constant operand-class* value>> class ;
M: constant move-spec class ;
INSTANCE: constant value
<PRIVATE
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
temp-reg over %move
operand-class temp-reg
tagged new
swap >>vreg
swap >>class
%move ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f constant } [ value>> swap load-literal ] }
{ { f float } [ %box-float ] }
{ { f unboxed-alien } [ %box-alien ] }
{ { f loc } [ %peek ] }
{ { float f } [ %unbox-float ] }
{ { unboxed-alien f } [ %unbox-alien ] }
{ { unboxed-byte-array f } [ %unbox-byte-array ] }
{ { unboxed-f f } [ %unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { loc f } [ swap %replace ] }
[ drop %move-via-temp ]
} case ;
! A compile-time stack
TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
: (loc) ( m stack -- n )
#! Utility for methods on <loc>
height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
[
over zero? [ 2drop ] [ execute ] if 0
] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> ( -- stack )
phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> ( -- stack )
phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
\ %inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
[ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
swap [ + ] curry change-height drop ;
: cut-phantom ( n phantom -- seq )
swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
[ stack>> length head-slice* ] keep
[ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
2dup add-locs
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
[ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
[ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ unboxed-f [ <unboxed-f> ] }
{ unboxed-c-ptr [ <unboxed-c-ptr> ] }
[ drop ]
} case ;
: compatible? ( value spec -- ? )
>r move-spec r> {
{ [ 2dup = ] [ t ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
[ f ]
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
[ nip reg-spec>class ]
} cond ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap operand-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
dupd alloc-vreg-for dup rot %move
] [
drop
] if ;
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
[ <vreg> ] curry map swap diff
>vector ;
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
{ int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
: do-shuffle ( hash -- )
dup assoc-empty? [
drop
] [
"live-locs" set
[ lazy-store ] each-loc
] if ;
: fast-shuffle ( locs -- )
#! We have enough free registers to load all shuffle inputs
#! at once
[ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
: minimal-ds-loc ( phantom -- n )
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
[ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
#! from the phantom stacks. We can clobber there all we want
[ minimal-ds-loc ] each-phantom min 1- ;
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
[ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
#! inputs, so we use a single temporary register, together
#! with the area of the data stack above the stack pointer
find-tmp-loc slow-shuffle-mapping [
[
swap dup cached? [ vreg>> ] when %move
] assoc-each
] keep >hashtable do-shuffle ;
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
[
\ free-vregs [ [ clone ] assoc-map ] change
live-locs dup fast-shuffle?
[ fast-shuffle ] [ slow-shuffle ] if
] with-scope ;
: finalize-vregs ( -- )
#! Store any vregs to their final stack locations.
[
dup loc? over cached? or [ 2drop ] [ %move ] if
] each-loc ;
: reset-phantom ( phantom -- )
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
over stack>> delete-all
swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
double-float-regs free-vregs length <=
>r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: vreg-substitution ( value vreg -- pair )
dupd <cached> 2array ;
: substitute-vreg? ( old new -- ? )
#! We don't substitute locs for float or alien vregs,
#! since in those cases the boxing overhead might kill us.
vreg>> tagged? >r loc? r> and ;
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ value>> ] when r> set ;
: lazy-load ( values template -- )
#! Set operand vars here.
2dup [ first (lazy-load) ] 2map
dup rot [ second set-operand ] 2each
substitute-vregs ;
: load-inputs ( -- )
+input+ get
[ length phantom-datastack get phantom-input ] keep
lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
phantoms [ stack>> ] bi@ append [
dup cached? [ vreg>> ] when swap member?
] with contains? ;
: outputs-clash? ( -- ? )
output-vregs append clash? ;
: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
: count-input-vregs ( phantom spec -- )
phantom&spec [
>r dup cached? [ vreg>> ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
[
0 int-regs set
0 double-float-regs set
count-scratch-regs
phantom-retainstack get swap count-input-vregs
phantom-datastack get swap count-input-vregs
int-regs get double-float-regs get
] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
: guess-template-vregs ( -- int# float# )
+input+ get { } +scratch+ get guess-vregs ;
: template-inputs ( -- )
! Load input values into registers
load-inputs
! Allocate scratch registers
alloc-scratch
! If outputs clash, we write values back to the stack
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
+output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
#! fixnum, see if the quotation yields true when applied
#! to the fixnum. Otherwise, the values don't match. If the
#! spec is not a quotation, its a reg-class, in which case
#! the value is always good.
dup quotation? [
over constant?
[ >r value>> r> call ] [ 2drop f ] if
] [
2drop t
] if ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
guess-template-vregs free-vregs? [
finalize-contents compute-free-vregs
] unless ;
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
phantom-datastack get
over length over add-locs
stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
ensure-template-vregs
template-inputs call template-outputs
] bind
compute-free-vregs ; inline
: do-template ( pair -- )
#! Use with return value from find-template
first2 with-template ;
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot hash }
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
[ in>> length phantom-datastack get phantom-input ] keep
shuffle phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-datastack get phantom-input
phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
phantom-retainstack get phantom-input
phantom-datastack get phantom-append ;
: phantom-drop ( n -- )
phantom-datastack get phantom-input drop ;
: phantom-rdrop ( n -- )
phantom-retainstack get phantom-input drop ;

1
basis/compiler/generator/registers/summary.txt
View File

@ -1 +0,0 @@
Register allocation and intrinsic selection

45
basis/compiler/intrinsics/intrinsics.factor
View File

@ -1,45 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple classes.tuple.private math arrays
byte-arrays words stack-checker.known-words ;
IN: compiler.intrinsics
ERROR: missing-intrinsic ;
: (tuple) ( n -- tuple ) missing-intrinsic ;
\ (tuple) { tuple-layout } { tuple } define-primitive
\ (tuple) make-flushable
: (array) ( n -- array ) missing-intrinsic ;
\ (array) { integer } { array } define-primitive
\ (array) make-flushable
: (byte-array) ( n -- byte-array ) missing-intrinsic ;
\ (byte-array) { integer } { byte-array } define-primitive
\ (byte-array) make-flushable
: (ratio) ( -- ratio ) missing-intrinsic ;
\ (ratio) { } { ratio } define-primitive
\ (ratio) make-flushable
: (complex) ( -- complex ) missing-intrinsic ;
\ (complex) { } { complex } define-primitive
\ (complex) make-flushable
: (wrapper) ( -- wrapper ) missing-intrinsic ;
\ (wrapper) { } { wrapper } define-primitive
\ (wrapper) make-flushable
: (set-slot) ( val obj n -- ) missing-intrinsic ;
\ (set-slot) { object object fixnum } { } define-primitive
: (write-barrier) ( obj -- ) missing-intrinsic ;
\ (write-barrier) { object } { } define-primitive

2
basis/compiler/tests/alien.factor
View File

@ -173,7 +173,7 @@ C-STRUCT: rect
{ "float" "h" }
;
: <rect>
: <rect> ( x y w h -- rect )
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep

105
basis/compiler/tests/intrinsics.factor
View File

@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
namespaces libc sequences.private io.encodings.ascii
classes ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
@ -27,7 +28,10 @@ IN: compiler.tests
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
[ { f f } ] [ 2 f <array> ] unit-test
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
@ -37,13 +41,19 @@ IN: compiler.tests
! Write barrier hits on the wrong value were causing segfaults
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
!
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@ -158,6 +168,10 @@ IN: compiler.tests
[ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
[ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
[ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@ -252,31 +266,36 @@ cell 8 = [
! Some randomized tests
: compiled-fixnum* fixnum* ;
: test-fixnum* ( -- )
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if ;
[ ] [ 10000 [ test-fixnum* ] times ] unit-test
[ ] [
10000 [
32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if
] times
] unit-test
: compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum ( -- )
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
[ ] [
10000 [
32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if
] times
] unit-test
: compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum ( -- )
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
[ ] [
10000 [
5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if
] times
] unit-test
! Test overflow check removal
[ t ] [
@ -377,25 +396,23 @@ cell 8 = [
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
[ t ] [ pi pi <double> *double = ] unit-test
@ -461,3 +478,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
] compile-call
b>>
] unit-test
: mutable-value-bug-1 ( a b -- c )
swap [
{ tuple } declare 1 slot
] [
0 slot
] if ;
[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
: mutable-value-bug-2 ( a b -- c )
swap [
0 slot
] [
{ tuple } declare 1 slot
] if ;
[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test

26
basis/compiler/tests/peg-regression.factor Normal file
View File

@ -0,0 +1,26 @@
! Calling the compiler at parse time and having it compile
! generic words defined in the current compilation unit would
! fail. This is a regression from the 'remake-generic'
! optimization, which would batch generic word updates at the
! end of a compilation unit.
USING: kernel accessors peg.ebnf ;
IN: compiler.tests
TUPLE: pipeline-expr background ;
GENERIC: blah ( a -- b )
M: pipeline-expr blah ;
: ast>pipeline-expr ( -- obj )
pipeline-expr new blah ;
EBNF: expr
pipeline = "hello" => [[ ast>pipeline-expr ]]
;EBNF
USE: tools.test
[ t ] [ \ expr compiled>> ] unit-test
[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test

20
basis/compiler/tests/redefine12.factor Normal file
View File

@ -0,0 +1,20 @@
USING: kernel tools.test eval ;
IN: compiler.tests.redefine12
! A regression that came about when fixing the
! 'no method on classes-intersect?' bug
GENERIC: g ( a -- b )
M: object g drop t ;
: h ( a -- b ) dup [ g ] when ;
[ f ] [ f h ] unit-test
[ t ] [ "hi" h ] unit-test
TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
[ f ] [ T{ jeah } h ] unit-test

14
basis/compiler/tests/redefine2.factor
View File

@ -3,16 +3,16 @@ USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval ;
DEFER: blah
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
[ t ] [ blah new sequence? ] unit-test
[ t ] [ redefine2-test new sequence? ] unit-test
[ 3 ] [ 0 blah new nth-unsafe ] unit-test
[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test
[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
[ ] [ [ redefine2-test sequence remove-mixin-instance ] with-compilation-unit ] unit-test
[ f ] [ blah new sequence? ] unit-test
[ f ] [ redefine2-test new sequence? ] unit-test
[ 0 blah new nth-unsafe ] must-fail
[ 0 redefine2-test new nth-unsafe ] must-fail

14
basis/compiler/tests/simple.factor
View File

@ -1,8 +1,10 @@
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory vocabs parser eval ;
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
IN: compiler.tests
\ (compile) must-infer
! Test empty word
[ ] [ [ ] compile-call ] unit-test
@ -52,11 +54,11 @@ IN: compiler.tests
! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline
: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
[ ] [ t [ recursive ] compile-call ] unit-test
[ ] [ t [ recursive-test ] compile-call ] unit-test
[ ] [ t recursive ] unit-test
[ ] [ t recursive-test ] unit-test
! Make sure error reporting works

343
basis/compiler/tests/spilling.factor Normal file
View File

@ -0,0 +1,343 @@
USING: math.private kernel combinators accessors arrays
generalizations float-arrays tools.test ;
IN: compiler.tests
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
[ dup float+ ]
[ float>fixnum dup fixnum+fast ]
} cleave ;
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
nip 2 fixnum+fast
] [
drop {
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
[ dup fixnum+fast ]
} cleave
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
! The above don't really test spilling...
: spill-test-1 ( a -- b )
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast
dup 1 fixnum+fast fixnum>float
3array
3array [ 8 narray ] dip 2array
[ 8 narray [ 8 narray ] dip 2array ] dip 2array
2array ;
[
{
1
{
{ { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
{
{ 18 19 20 21 22 23 24 25 }
{ 26 27 { 28 29 30.0 } }
}
}
}
] [ 1 spill-test-1 ] unit-test
: spill-test-2 ( a -- b )
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
dup 1.0 float+
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float*
float* ;
[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test

220
basis/compiler/tests/templates-early.factor
View File

@ -1,220 +0,0 @@
! Testing templates machinery without compiling anything
IN: compiler.tests
USING: compiler compiler.generator compiler.generator.registers
compiler.generator.registers.private tools.test namespaces
sequences words kernel math effects definitions compiler.units
accessors cpu.architecture make ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
[ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
[ ] [ 0 <int-vreg> phantom-push ] unit-test
[ ] [ compute-free-vregs ] unit-test
[ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
[ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
[ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
[ 3 ] [ live-locs length ] unit-test
[ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
[ 2 ] [ live-locs length ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
H{ } clone compiled set
[ ] [ gensym gensym begin-compiling ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
3 fresh-object
[ f ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
[
[ ] [ init-templates ] unit-test
H{
{ +input+ { { f "x" } } }
} clone [
[ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
[ ] [ finalize-contents ] unit-test
[ ] [ [ template-inputs ] { } make drop ] unit-test
] bind
] with-scope
! Test template picking strategy
SYMBOL: template-chosen
: template-test ( a b -- c d ) ;
\ template-test {
{
[
1 template-chosen get push
] H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" "obj" } }
}
}
{
[
2 template-chosen get push
] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +output+ { "obj" "n" } }
}
}
} define-intrinsics
[ V{ 2 } ] [
V{ } clone template-chosen set
0 0 [ template-test ] compile-call 2drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
1 [ dup 0 template-test ] compile-call 3drop
template-chosen get
] unit-test
[ V{ 1 } ] [
V{ } clone template-chosen set
1 [ 0 template-test ] compile-call 2drop
template-chosen get
] unit-test
! Regression
[
[ ] [ init-templates ] unit-test
! dup dup
[ ] [
T{ effect f { "x" } { "x" "x" } } phantom-shuffle
T{ effect f { "x" } { "x" "x" } } phantom-shuffle
] unit-test
! This is not empty since a load instruction is emitted
[ f ] [
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we already loaded the value
[ t ] [
[ { { f "x" } } +input+ set load-inputs ] { } make
empty?
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
[ ] [ { object } set-operand-classes ] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
[ ] [ { object object } set-operand-classes ] unit-test
! 2dup
[ ] [
T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
phantom-shuffle
] unit-test
[ ] [
2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
[ ] [
1 phantom->r
] unit-test
! This should not fail
[ ] [ [ end-basic-block ] { } make drop ] unit-test
] with-scope
! Regression
SYMBOL: templates-chosen
V{ } clone templates-chosen set
: template-choice-1 ;
\ template-choice-1
[ "template-choice-1" templates-chosen get push ]
H{
{ +input+ { { f "obj" } { [ ] "n" } } }
{ +output+ { "obj" } }
} define-intrinsic
: template-choice-2 ;
\ template-choice-2
[ "template-choice-2" templates-chosen get push drop ]
{ { f "x" } { f "y" } } define-if-intrinsic
[ ] [
[ 2 template-choice-1 template-choice-2 ]
[ define-temp ] with-compilation-unit drop
] unit-test
[ V{ "template-choice-1" "template-choice-2" } ]
[ templates-chosen get ] unit-test

85
basis/compiler/tests/templates.factor
View File

@ -1,11 +1,15 @@
! Black box testing of templating optimization
USING: accessors arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators vectors ;
USING: generalizations accessors arrays compiler kernel
kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors float-arrays ;
IN: compiler.tests
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
! in here are still useful.
! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
[ "hi" ] [ [ "hi" ] compile-call ] unit-test
@ -101,9 +105,8 @@ unit-test
] [ define-temp ] with-compilation-unit drop
] unit-test
! Test how dispatch handles the end of a basic block
: try-breaking-dispatch ( n a b -- a b str )
: try-breaking-dispatch ( n a b -- x str )
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? )
@ -122,7 +125,7 @@ unit-test
] unit-test
! Regression
: hellish-bug-1 2drop ;
: hellish-bug-1 ( a b -- ) 2drop ;
: hellish-bug-2 ( i array x -- x )
2dup 1 slot eq? [ 2drop ] [
@ -132,7 +135,7 @@ unit-test
pick 2dup hellish-bug-1 3drop
] 2keep
] unless >r 2 fixnum+fast r> hellish-bug-2
] if ; inline
] if ; inline recursive
: hellish-bug-3 ( hash array -- )
0 swap hellish-bug-2 drop ;
@ -189,7 +192,7 @@ TUPLE: my-tuple ;
] unit-test
! Regression
: a-dummy ( -- ) drop "hi" print ;
: a-dummy ( a -- ) drop "hi" print ;
[ ] [
1 [
@ -203,50 +206,6 @@ TUPLE: my-tuple ;
] compile-call
] unit-test
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ t ] [ \ float-spill-bug compiled>> ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
@ -255,3 +214,19 @@ TUPLE: my-tuple ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
! Regression
: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
[ { f f f } ] [ t bad-value-bug ] unit-test
! PowerPC regression
TUPLE: id obj ;
: (gc-check-bug) ( a b -- c )
{ [ id boa ] [ id boa ] } dispatch ;
: gc-check-bug ( -- )
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test

2
basis/compiler/tree/builder/builder.factor
View File

@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
[ V{ } clone stack-visitor set ] prepose
'[ V{ } clone stack-visitor set @ ]
with-infer ; inline
: build-tree ( quot -- nodes )

18
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private
sorting.private combinators.short-circuit grouping prettyprint
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
@ -13,6 +13,7 @@ compiler.tree.builder
compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
compiler.tree.propagation.info
compiler.tree.checker
compiler.tree.debugger ;
@ -494,3 +495,18 @@ cell-bits 32 = [
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test
[ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
] unit-test
[ ] [
[ { null } declare [ 1 ] [ 2 ] if ]
build-tree normalize propagate cleanup check-nodes
] unit-test
[ t ] [
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test

5
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -5,7 +5,6 @@ classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
stack-checker.branches
compiler.intrinsics
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -79,7 +78,7 @@ GENERIC: cleanup* ( node -- node/nodes )
} cond ;
: remove-overflow-check ( #call -- #call )
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
[ no-overflow-variant ] change-word cleanup* ;
M: #call cleanup*
{
@ -103,7 +102,7 @@ M: #declare cleanup* drop f ;
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
{ 0 [ 2drop f ] }
{ 0 [ drop in-d>> #drop ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;

2
basis/compiler/tree/combinators/combinators.factor
View File

@ -48,7 +48,7 @@ IN: compiler.tree.combinators
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline

2
basis/compiler/tree/debugger/debugger.factor
View File

@ -24,7 +24,7 @@ IN: compiler.tree.debugger
GENERIC: node>quot ( node -- )
MACRO: match-choose ( alist -- )
[ [ ] curry ] assoc-map [ match-cond ] curry ;
[ '[ _ ] ] assoc-map '[ _ match-cond ] ;
MATCH-VARS: ?a ?b ?c ;

6
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -6,8 +6,9 @@ math.functions compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple compiler.intrinsics namespaces
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
propagate
cleanup
escape-analysis
dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@ -307,7 +309,7 @@ C: <ro-box> ro-box
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]

1
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -4,7 +4,6 @@ USING: kernel accessors sequences classes.tuple
classes.tuple.private arrays math math.private slots.private
combinators deques search-deques namespaces fry classes
classes.algebra stack-checker.state
compiler.intrinsics
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes

86
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,10 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays accessors sequences sequences.private words
fry namespaces make math math.order memoize classes.builtin
classes.tuple.private slots.private combinators layouts
byte-arrays alien.accessors
compiler.intrinsics
USING: kernel accessors sequences words memoize classes.builtin
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -15,14 +11,19 @@ IN: compiler.tree.finalization
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! built-in type predicates; these cannot be expanded before
! propagation since we need to see 'fixnum?' instead of
! 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
: splice-final ( quot -- nodes ) splice-quot finalize ;
M: #copy finalize* drop f ;
M: #shuffle finalize*
@ -34,77 +35,12 @@ M: #shuffle finalize*
word>> "predicating" word-prop builtin-class? ;
MEMO: builtin-predicate-expansion ( word -- nodes )
def>> splice-quot ;
def>> splice-final ;
: expand-builtin-predicate ( #call -- nodes )
word>> builtin-predicate-expansion ;
: first-literal ( #call -- obj ) node-input-infos first literal>> ;
: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
: expand-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
last-literal tuple-layout?
] [ drop f ] if ;
MEMO: (tuple-boa-expansion) ( n -- quot )
[
[ 2 + ] map <reversed>
[ '[ [ _ set-slot ] keep ] % ] each
] [ ] make ;
: tuple-boa-expansion ( layout -- quot )
#! No memoization here since otherwise we'd hang on to
#! tuple layout objects.
size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
: expand-tuple-boa ( #call -- node )
last-literal tuple-boa-expansion ;
MEMO: <array>-expansion ( n -- quot )
[
[ swap (array) ] %
[ \ 2dup , , [ swap set-array-nth ] % ] each
\ nip ,
] [ ] make splice-quot ;
: expand-<array>? ( #call -- ? )
dup word>> \ <array> eq? [
first-literal dup integer?
[ 0 32 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<array> ( #call -- node )
first-literal <array>-expansion ;
: bytes>cells ( m -- n ) cell align cell /i ;
MEMO: <byte-array>-expansion ( n -- quot )
[
[ (byte-array) ] %
bytes>cells [ cell * ] map
[ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
] [ ] make splice-quot ;
: expand-<byte-array>? ( #call -- ? )
dup word>> \ <byte-array> eq? [
first-literal dup integer?
[ 0 128 between? ] [ drop f ] if
] [ drop f ] if ;
: expand-<byte-array> ( #call -- nodes )
first-literal <byte-array>-expansion ;
M: #call finalize*
{
{ [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
{ [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
{ [ dup expand-<array>? ] [ expand-<array> ] }
{ [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
[ ]
} cond ;
dup builtin-predicate? [ expand-builtin-predicate ] when ;
M: node finalize* ;
: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

13
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

@ -53,17 +53,8 @@ M: node maybe-modularize* 2drop ;
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
dup word>> {
{ [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
! { [
! {
! mod-integer-fixnum
! mod-integer-integer
! mod-fixnum-integer
! } memq?
! ] [ ] }
[ drop ]
} cond ;
dup word>> \ >fixnum eq?
[ in-d>> first maybe-modularize ] [ drop ] if ;
M: node compute-modularized-values* drop ;

4
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -40,8 +40,8 @@ M: #dispatch live-branches
SYMBOL: infer-children-data
: copy-value-info ( -- )
value-infos [ clone ] change
constraints [ clone ] change ;
value-infos [ H{ } clone suffix ] change
constraints [ H{ } clone suffix ] change ;
: no-value-info ( -- )
value-infos off

6
basis/compiler/tree/propagation/constraints/constraints.factor
View File

@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: true-constraint satisfied?
@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: false-constraint satisfied?
@ -83,7 +83,7 @@ TUPLE: implication p q ;
C: --> implication
: assume-implication ( p q -- )
[ constraints get [ swap suffix ] change-at ]
[ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*

4
basis/compiler/tree/propagation/info/info-tests.factor
View File

@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object-info value-info-intersect =
] unit-test
[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test

18
basis/compiler/tree/propagation/info/info.factor
View File

@ -34,7 +34,7 @@ slots ;
: null-info T{ value-info f null empty-interval } ; inline
: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
: object-info T{ value-info f object full-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
@ -43,7 +43,7 @@ slots ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
dup empty-interval eq? [
dup special-interval? [
2drop f f
] [
dup from>> first {
@ -243,7 +243,7 @@ DEFER: (value-info-union)
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
{ [ over literal?>> not ] [ 2drop f ] }
{ [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
@ -262,17 +262,19 @@ DEFER: (value-info-union)
]
} cond ;
! Current value --> info mapping
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info ( value -- info )
resolve-copy value-infos get at null-info or ;
resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
resolve-copy value-infos get set-at ;
resolve-copy value-infos get peek set-at ;
: refine-value-info ( info value -- )
resolve-copy value-infos get [ value-info-intersect ] change-at ;
resolve-copy value-infos get
[ assoc-stack value-info-intersect ] 2keep
peek set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;
@ -307,5 +309,5 @@ SYMBOL: value-infos
: immutable-tuple-boa? ( #call -- ? )
dup word>> \ <tuple-boa> eq? [
dup in-d>> peek node-value-info
literal>> class>> immutable-tuple-class?
literal>> first immutable-tuple-class?
] [ drop f ] if ;

11
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -131,7 +131,7 @@ DEFER: (flat-length)
] bi* + + + + + ;
: should-inline? ( #call word -- ? )
inlining-rank 5 >= ;
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
@ -164,7 +164,16 @@ SYMBOL: history
first object swap eliminate-dispatch ;
: do-inlining ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
#! is built at the end of the compilation unit. We do not
#! attempt inlining at this stage since the stack discipline
#! is not finalized yet, so dispatch# might return an out
#! of bounds value. This case comes up if a parsing word
#! calls the compiler at parse time (doing so is
#! discouraged, but it should still work.)
{
{ [ dup deferred? ] [ 2drop f ] }
{ [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }

7
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -7,7 +7,6 @@ classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private
definitions
stack-checker.state
compiler.intrinsics
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@ -277,12 +276,12 @@ generic-comparison-ops [
}
} cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
[ 2nip ] curry "outputs" set-word-prop
'[ 2drop _ ] "outputs" set-word-prop
] each
{ <tuple> <tuple-boa> (tuple) } [
{ <tuple> <tuple-boa> } [
[
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
[ clear ] dip
] "outputs" set-word-prop
] each

Some files were not shown because too many files have changed in this diff Show More