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

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

db4
Anton Gorenko 2010-05-10 23:42:41 +06:00
parent 56280003c5 9321f9378a
commit b2b5365ebd
52 changed files with 867 additions and 945 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/alien/arrays/arrays.factor
View File

@ -22,17 +22,11 @@ M: array c-type-align first c-type-align ;
M: array c-type-align-first first c-type-align-first ;
M: array unbox-parameter drop void* unbox-parameter ;
M: array unbox-return drop void* unbox-return ;
M: array box-parameter drop void* box-parameter ;
M: array box-return drop void* box-return ;
M: array base-type drop void* base-type ;
M: array stack-size drop void* stack-size ;
M: array flatten-c-type drop { int-rep } ;
M: array flatten-c-type drop void* flatten-c-type ;
PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ;
@ -43,35 +37,19 @@ M: string-type c-type-class drop object ;
M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop void* heap-size ;
M: string-type heap-size drop void* heap-size ;
M: string-type c-type-align
drop void* c-type-align ;
M: string-type c-type-align drop void* c-type-align ;
M: string-type c-type-align-first
drop void* c-type-align-first ;
M: string-type c-type-align-first drop void* c-type-align-first ;
M: string-type unbox-parameter
drop void* unbox-parameter ;
M: string-type base-type drop void* base-type ;
M: string-type unbox-return
drop void* unbox-return ;
M: string-type stack-size drop void* stack-size ;
M: string-type box-parameter
drop void* box-parameter ;
M: string-type c-type-rep drop int-rep ;
M: string-type box-return
drop void* box-return ;
M: string-type stack-size
drop void* stack-size ;
M: string-type c-type-rep
drop int-rep ;
M: string-type flatten-c-type
drop { int-rep } ;
M: string-type flatten-c-type drop void* flatten-c-type ;
M: string-type c-type-boxer-quot
second dup binary =

15
basis/alien/c-types/c-types-docs.factor
View File

@ -43,21 +43,6 @@ HELP: c-setter
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: box-parameter
{ $values { "n" math:integer } { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: box-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a C value stored in return registers into a Factor object to be pushed on the data stack." }
{ $notes "This is an internal word used by the compiler when compiling alien calls." } ;
HELP: unbox-return
{ $values { "c-type" "a C type" } }
{ $description "Generates code for converting a Factor value on the data stack into a C value to be stored in the return registers." }
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: define-deref
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }

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

@ -111,27 +111,11 @@ GENERIC: c-type-align-first ( name -- n )
M: abstract-c-type c-type-align-first align-first>> ;
: c-type-box ( n c-type -- )
[ rep>> ] [ boxer>> ] bi %box ;
GENERIC: base-type ( c-type -- c-type )
: c-type-unbox ( n c-type -- )
[ rep>> ] [ unboxer>> ] bi %unbox ;
M: c-type-name base-type c-type ;
GENERIC: box-parameter ( n c-type -- )
M: c-type box-parameter c-type-box ;
GENERIC: box-return ( c-type -- )
M: c-type box-return f swap c-type-box ;
GENERIC: unbox-parameter ( n c-type -- )
M: c-type unbox-parameter c-type-unbox ;
GENERIC: unbox-return ( c-type -- )
M: c-type unbox-return f swap c-type-unbox ;
M: c-type base-type ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
@ -179,10 +163,7 @@ PROTOCOL: c-type-protocol
c-type-setter
c-type-align
c-type-align-first
box-parameter
box-return
unbox-parameter
unbox-return
base-type
heap-size
stack-size
flatten-c-type ;
@ -204,18 +185,6 @@ TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- c-type )
long-long-type new ;
M: long-long-type unbox-parameter ( n c-type -- )
unboxer>> %unbox-long-long ;
M: long-long-type unbox-return ( c-type -- )
f swap unbox-parameter ;
M: long-long-type box-parameter ( n c-type -- )
boxer>> %box-long-long ;
M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
M: long-long-type flatten-c-type
int-rep (flatten-c-type) ;

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

@ -117,6 +117,8 @@ gc
" done" print flush
"alien.syntax" require
"alien.complex" require
"io.streams.byte-array.fast" require
] unless

4
basis/bootstrap/help/help.factor
View File

@ -6,12 +6,10 @@ IN: bootstrap.help
: load-help ( -- )
"help.lint" require
"help.vocabs" require
"alien.syntax" require
"compiler" require
t load-help? set-global
[ vocab ] load-vocab-hook [
[ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [
dictionary get values
[ docs-loaded?>> not ] filter
[ load-docs ] each

2
basis/calendar/calendar-docs.factor
View File

@ -8,7 +8,7 @@ HELP: duration
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ;
HELP: timestamp
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ;
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ;
{ timestamp duration } related-words

12
basis/classes/struct/struct.factor
View File

@ -169,20 +169,10 @@ M: struct-c-type c-type ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
M: struct-c-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-c-type box-parameter
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
M: struct-c-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
M: struct-c-type box-return
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: struct-c-type base-type ;
M: struct-c-type stack-size
[ heap-size cell align ] [ stack-size ] if-value-struct ;

4
basis/compiler/cfg/block-joining/block-joining.factor
View File

@ -10,9 +10,9 @@ IN: compiler.cfg.block-joining
! before stack analysis.
: join-block? ( bb -- ? )
{
[ kill-block? not ]
[ kill-block?>> not ]
[ predecessors>> length 1 = ]
[ predecessor kill-block? not ]
[ predecessor kill-block?>> not ]
[ predecessor successors>> length 1 = ]
[ [ predecessor ] keep back-edge? not ]
} 1&& ;

21
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math math.order
sequences assocs namespaces vectors fry arrays splitting
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
USING: accessors combinators combinators.short-circuit kernel
math math.order sequences assocs namespaces vectors fry arrays
splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
: clone-instructions ( insns -- insns' )
@ -15,10 +16,12 @@ IN: compiler.cfg.branch-splitting
! 'back-edge?' work.
<basic-block>
swap
[ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ]
[ number>> >>number ]
tri ;
{
[ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ]
[ kill-block?>> >>kill-block? ]
[ number>> >>number ]
} cleave ;
: new-blocks ( bb -- copies )
dup predecessors>> [

8
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -14,13 +14,7 @@ GENERIC: compute-stack-frame* ( insn -- )
frame-required? on
stack-frame [ max-stack-frame ] change ;
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
##alien-assembly
##alien-callback ;
M: stack-frame-insn compute-stack-frame*
M: ##stack-frame compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame* drop frame-required? on ;

296
basis/compiler/cfg/builder/alien/alien.factor Normal file
View File

@ -0,0 +1,296 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays layouts math math.order math.parser
combinators fry sequences locals alien alien.private
alien.strings alien.c-types alien.libraries classes.struct
namespaces kernel strings libc quotations cpu.architecture
compiler.alien compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers
compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
GENERIC: next-fastcall-param ( rep -- )
: ?dummy-stack-params ( rep -- )
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( rep -- )
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs inc ] when ;
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
M: stack-params reg-class-full? 2drop t ;
M: reg-class reg-class-full?
[ get ] swap '[ _ param-regs length ] bi >= ;
: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
[ rep-size cell align stack-params +@ ] dip
stack-params dup ;
: alloc-fastcall-param ( rep -- n reg-class rep )
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
:: alloc-parameter ( rep abi -- reg rep )
rep dup reg-class-of abi reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
[ abi param-reg ] dip ;
: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-fastcall-counts call ] with-scope ; inline
:: move-parameters ( params 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).
0 params alien-parameters flatten-c-types [
[ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
[ rep-size cell align + ]
2bi
] each drop ; inline
: parameter-offsets ( types -- offsets )
0 [ stack-size + ] accumulate nip ;
: prepare-parameters ( parameters -- offsets types indices )
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
GENERIC: unbox-parameter ( src n c-type -- )
M: c-type unbox-parameter
[ rep>> ] [ unboxer>> ] bi ##unbox ;
M: long-long-type unbox-parameter
unboxer>> ##unbox-long-long ;
M: struct-c-type unbox-parameter
[ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ]
[ base-type unbox-parameter ]
if-value-struct ;
: unbox-parameters ( offset node -- )
parameters>> swap
'[
prepare-parameters
[
[ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*
unbox-parameter
] 3each
]
[ length neg ##inc-d ]
bi ;
: 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 registers on
#! architectures where parameters are passed in registers.
[
[ prepare-box-struct ] keep
[ unbox-parameters ] keep
\ ##load-param-reg move-parameters
] with-param-regs ;
GENERIC: box-return ( c-type -- dst )
M: c-type box-return
[ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;
M: long-long-type box-return
[ f ] dip boxer>> ^^box-long-long ;
M: struct-c-type box-return
[ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
: box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
M: string dlsym-valid? dlsym ;
M: array dlsym-valid? '[ _ dlsym ] any? ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd dlsym-valid?
[ drop ] [ cfg get word>> no-such-symbol ] if
] [ dll-path cfg get word>> no-such-library drop ] if ;
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
: 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 [ stack-size ] map-sum >>params ] bi
t >>calls-vm? ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-node ( node quot -- )
'[
make-kill-block
params>>
[ <alien-stack-frame> ##stack-frame ]
_
[ alien-node-height ]
tri
] emit-trivial-block ; inline
M: #alien-invoke emit-node
[
! Unbox parameters
dup objects>registers
! Call function
dup alien-invoke-dlsym ##alien-invoke
! Box return value
dup ##cleanup
box-return*
] emit-alien-node ;
M: #alien-indirect emit-node
[
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr
{
[ drop objects>registers ]
[ nip ##alien-indirect ]
[ drop ##cleanup ]
[ drop box-return* ]
} 2cleave
] emit-alien-node ;
M: #alien-assembly emit-node
[
[ objects>registers ]
[ quot>> ##alien-assembly ]
[ box-return* ]
tri
] emit-alien-node ;
GENERIC: box-parameter ( n c-type -- dst )
M: c-type box-parameter
[ rep>> ] [ boxer>> ] bi ^^box ;
M: long-long-type box-parameter
boxer>> ^^box-long-long ;
M: struct-c-type box-parameter
[ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;
: box-parameters ( params -- )
alien-parameters
[ length ##inc-d ]
[
prepare-parameters
[
next-vreg next-vreg ##save-context
base-type box-parameter swap <ds-loc> ##replace
] 3each
] bi ;
: registers>objects ( node -- )
! Generate code for boxing input parameters in a callback.
[
dup \ ##save-param-reg move-parameters
##begin-callback
next-vreg next-vreg ##restore-context
box-parameters
] with-param-regs ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup void? ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ 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
yield-hook get
'[ _ _ do-callback ]
>quotation ;
GENERIC: unbox-return ( src c-type -- )
M: c-type unbox-return
[ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;
M: long-long-type unbox-return
[ f ] dip unboxer>> ##unbox-long-long ;
M: struct-c-type unbox-return
[ ^^unbox-any-c-ptr ] dip
[ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
[
[ registers>objects ]
[ wrap-callback-quot ##alien-callback ]
[
alien-return [ ##end-callback ] [
[ D 0 ^^peek ] dip
##end-callback
base-type unbox-return
] if-void
] tri
] emit-alien-node
##epilogue
##return
] with-cfg-builder ;

8
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel make math namespaces sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
@ -31,6 +31,9 @@ IN: compiler.cfg.builder.blocks
call
##branch begin-basic-block ; inline
: make-kill-block ( -- )
basic-block get t >>kill-block? drop ;
: call-height ( #call -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
@ -38,6 +41,7 @@ IN: compiler.cfg.builder.blocks
[
[ word>> ##call ]
[ call-height adjust-d ] bi
make-kill-block
] emit-trivial-block ;
: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
@ -66,7 +70,7 @@ IN: compiler.cfg.builder.blocks
[ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
: emit-conditional ( branches -- )
! branchies is a sequence of pairs as above
! branches is a sequence of pairs as above
end-basic-block
[ merge-heights begin-basic-block ]
[ set-successors ]

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

@ -57,6 +57,7 @@ GENERIC: emit-node ( node -- )
[ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
make-kill-block
##prologue
##branch
begin-basic-block ;
@ -82,8 +83,12 @@ GENERIC: emit-node ( node -- )
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
[ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
if ;
[
[
[ ##call ] [ adjust-d ] bi*
make-kill-block
] emit-trivial-block
] if ;
! #recursive
: recursive-height ( #recursive -- n )
@ -195,7 +200,11 @@ M: #shuffle emit-node
! #return
: emit-return ( -- )
##branch begin-basic-block ##epilogue ##return ;
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
M: #return emit-node drop emit-return ;
@ -205,49 +214,6 @@ M: #return-recursive emit-node
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
! 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 [ stack-size ] map-sum >>params ] bi
t >>calls-vm? ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-node ( node quot -- )
[
[ params>> dup dup <alien-stack-frame> ] dip call
alien-node-height
] emit-trivial-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-assembly emit-node
[ ##alien-assembly ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
[ ##alien-callback ] emit-alien-node
##epilogue
##return
] with-cfg-builder ;
! No-op nodes
M: #introduce emit-node drop ;

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

@ -9,6 +9,7 @@ number
{ instructions vector }
{ successors vector }
{ predecessors vector }
{ kill-block? boolean }
{ unlikely? boolean } ;
: <basic-block> ( -- bb )

41
basis/compiler/cfg/checker/checker.factor
View File

@ -7,50 +7,11 @@ compiler.cfg.utilities compiler.cfg.finalization
compiler.utilities ;
IN: compiler.cfg.checker
! Check invariants
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
dup instructions>> dup penultimate ##epilogue? [
{
[ length 2 = ]
[ last { [ ##return? ] [ ##jump? ] } 1|| ]
} 1&&
] [ last ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
: check-last-instruction ( bb -- )
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
[ conditional-branch-insn? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-kill-insn bb ;
: check-kill-instructions ( bb -- )
dup instructions>> [ kill-vreg-insn? ] any?
[ bad-kill-insn ] [ drop ] if ;
: check-normal-block ( bb -- )
[ check-last-instruction ]
[ check-kill-instructions ]
bi ;
ERROR: bad-successors ;
: check-successors ( bb -- )
dup successors>> [ predecessors>> member-eq? ] with all?
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
[ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
[ check-successors ]
bi ;
: check-cfg ( cfg -- )
[ check-basic-block ] each-basic-block ;
[ check-successors ] each-basic-block ;

24
basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
View File

@ -18,27 +18,21 @@ MIXIN: dataflow-analysis
: <dfa-worklist> ( cfg dfa -- queue )
block-order <hashed-dlist> [ push-all-front ] keep ;
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
:: compute-in-set ( bb out-sets dfa -- set )
! Only consider initialized sets.
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets ;
bb kill-block?>> [ f ] [
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets
] if ;
:: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set
bb in-sets maybe-set-at ; inline
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-out-set 3drop f ;
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
bb in-sets at bb dfa transfer-set ;
:: compute-out-set ( bb in-sets dfa -- set )
bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ;
:: update-out-set ( bb in-sets out-sets dfa -- ? )
bb in-sets dfa compute-out-set

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

@ -34,6 +34,10 @@ INSN: ##load-tagged
def: dst/tagged-rep
literal: val ;
INSN: ##load-float
def: dst/float-rep
literal: val ;
INSN: ##load-double
def: dst/double-rep
literal: val ;
@ -605,17 +609,67 @@ use: src/tagged-rep
literal: offset ;
! FFI
INSN: ##stack-frame
literal: stack-frame ;
INSN: ##box
def: dst/tagged-rep
literal: n rep boxer ;
INSN: ##box-long-long
def: dst/tagged-rep
literal: n boxer ;
INSN: ##box-small-struct
def: dst/tagged-rep
literal: c-type ;
INSN: ##box-large-struct
def: dst/tagged-rep
literal: n c-type ;
INSN: ##unbox
use: src/tagged-rep
literal: n rep unboxer ;
INSN: ##unbox-long-long
use: src/tagged-rep
literal: n unboxer ;
INSN: ##unbox-large-struct
use: src/int-rep
literal: n c-type ;
INSN: ##unbox-small-struct
use: src/int-rep
literal: c-type ;
INSN: ##prepare-box-struct ;
INSN: ##load-param-reg
literal: offset reg rep ;
INSN: ##alien-invoke
literal: params stack-frame ;
literal: symbols dll ;
INSN: ##cleanup
literal: params ;
INSN: ##alien-indirect
literal: params stack-frame ;
use: src/int-rep ;
INSN: ##alien-assembly
literal: params stack-frame ;
literal: quot ;
INSN: ##save-param-reg
literal: offset reg rep ;
INSN: ##begin-callback ;
INSN: ##alien-callback
literal: params stack-frame ;
literal: quot ;
INSN: ##end-callback ;
! Control flow
INSN: ##phi
@ -706,6 +760,9 @@ literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
INSN: ##restore-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks
INSN: ##check-nursery-branch
literal: size cc
@ -752,16 +809,23 @@ UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
UNION: clobber-insn
##call-gc
##unary-float-function
##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
##prologue
##epilogue
##binary-float-function
##box
##box-long-long
##box-small-struct
##box-large-struct
##unbox
##unbox-long-long
##unbox-large-struct
##unbox-small-struct
##prepare-box-struct
##load-param-reg
##alien-invoke
##alien-indirect
##alien-callback ;
##alien-assembly
##save-param-reg
##begin-callback
##end-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers

6
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -51,7 +51,11 @@ IN: compiler.cfg.intrinsics.fixnum
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb )
[ ##call -1 adjust-d ] with-branch ;
[
##call
-1 adjust-d
make-kill-block
] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because

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

@ -35,10 +35,9 @@ IN: compiler.cfg.linear-scan.allocation
} cond ;
: spill-at-sync-point ( live-interval n -- ? )
! If the live interval has a usage at 'n', don't spill it,
! since this means its being defined by the sync point
! instruction. Output t if this is the case.
2dup [ uses>> ] dip '[ n>> _ = ] any?
! If the live interval has a definition at 'n', don't spill
2dup [ uses>> ] dip
'[ [ def-rep>> ] [ n>> _ = ] bi and ] any?
[ 2drop t ] [ spill f ] if ;
: handle-sync-point ( n -- )

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

@ -28,14 +28,20 @@ ERROR: bad-live-ranges interval ;
[ swap first from<< ]
2bi ;
: last-use-rep ( live-interval -- rep/f )
last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline
: assign-spill ( live-interval -- )
dup [ vreg>> ] [ last-use rep>> ] bi
assign-spill-slot >>spill-to drop ;
dup last-use-rep dup [
>>spill-rep
dup [ vreg>> ] [ spill-rep>> ] bi
assign-spill-slot >>spill-to drop
] [ 2drop ] if ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
! then it is the second child of an interval that was split. We reload
! the value and let the resolve pass insert a split later.
! the value and let the resolve pass insert a spill later.
dup uses>> empty? [ drop f ] [
{
[ ]
@ -46,9 +52,15 @@ ERROR: bad-live-ranges interval ;
} cleave
] if ;
: first-use-rep ( live-interval -- rep/f )
first-use use-rep>> ; inline
: assign-reload ( live-interval -- )
dup [ vreg>> ] [ first-use rep>> ] bi
assign-spill-slot >>reload-from drop ;
dup first-use-rep dup [
>>reload-rep
dup [ vreg>> ] [ reload-rep>> ] bi
assign-spill-slot >>reload-from drop
] [ 2drop ] if ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,

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

@ -1,6 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
USING: accessors arrays assocs combinators
combinators.short-circuit fry hints kernel locals
math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
@ -25,7 +26,9 @@ IN: compiler.cfg.linear-scan.allocation.splitting
] bi ;
: split-uses ( uses n -- before after )
'[ n>> _ <= ] partition ;
[ '[ n>> _ < ] filter ]
[ '[ n>> _ > ] filter ]
2bi ;
ERROR: splitting-too-early ;

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

@ -93,7 +93,7 @@ SYMBOL: machine-live-outs
init-unhandled ;
: insert-spill ( live-interval -- )
[ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
[ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
@ -113,18 +113,10 @@ SYMBOL: machine-live-outs
pending-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
[ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
: insert-reload? ( live-interval -- ? )
! Don't insert a reload if the register will be written to
! before being read again.
{
[ reload-from>> ]
[ first-use type>> +use+ eq? ]
} 1&& ;
[ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ;
: handle-reload ( live-interval -- )
dup insert-reload? [ insert-reload ] [ drop ] if ;
dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-interval ( live-interval -- )
[ add-pending ] [ handle-reload ] bi ;

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

@ -91,18 +91,20 @@ H{
{ reg-class float-regs }
{ start 0 }
{ end 2 }
{ uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } }
{ ranges V{ T{ live-range f 0 2 } } }
{ spill-to T{ spill-slot f 0 } }
{ spill-rep float-rep }
}
T{ live-interval
{ vreg 1 }
{ reg-class float-regs }
{ start 5 }
{ end 5 }
{ uses V{ T{ vreg-use f float-rep 5 } } }
{ uses V{ T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 5 5 } } }
{ reload-from T{ spill-slot f 0 } }
{ reload-rep float-rep }
}
] [
T{ live-interval
@ -110,29 +112,22 @@ H{
{ reg-class float-regs }
{ start 0 }
{ end 5 }
{ uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 2 split-for-spill
] unit-test
[
T{ live-interval
{ vreg 2 }
{ reg-class float-regs }
{ start 0 }
{ end 1 }
{ uses V{ T{ vreg-use f float-rep 0 } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 4 } }
}
f
T{ live-interval
{ vreg 2 }
{ reg-class float-regs }
{ start 1 }
{ end 5 }
{ uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ uses V{ T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 1 5 } } }
{ reload-from T{ spill-slot f 4 } }
{ reload-rep float-rep }
}
] [
T{ live-interval
@ -140,7 +135,7 @@ H{
{ reg-class float-regs }
{ start 0 }
{ end 5 }
{ uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
{ ranges V{ T{ live-range f 0 5 } } }
} 0 split-for-spill
] unit-test
@ -151,18 +146,20 @@ H{
{ reg-class float-regs }
{ start 0 }
{ end 1 }
{ uses V{ T{ vreg-use f float-rep 0 } } }
{ uses V{ T{ vreg-use f 0 float-rep f } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 8 } }
{ spill-rep float-rep }
}
T{ live-interval
{ vreg 3 }
{ reg-class float-regs }
{ start 20 }
{ end 30 }
{ uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 20 30 } } }
{ reload-from T{ spill-slot f 8 } }
{ reload-rep float-rep }
}
] [
T{ live-interval
@ -170,11 +167,75 @@ H{
{ reg-class float-regs }
{ start 0 }
{ end 30 }
{ uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
] unit-test
! Don't insert reload if first usage is a def
[
T{ live-interval
{ vreg 4 }
{ reg-class float-regs }
{ start 0 }
{ end 1 }
{ uses V{ T{ vreg-use f 0 float-rep f } } }
{ ranges V{ T{ live-range f 0 1 } } }
{ spill-to T{ spill-slot f 12 } }
{ spill-rep float-rep }
}
T{ live-interval
{ vreg 4 }
{ reg-class float-regs }
{ start 20 }
{ end 30 }
{ uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 20 30 } } }
}
] [
T{ live-interval
{ vreg 4 }
{ reg-class float-regs }
{ start 0 }
{ end 30 }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
} 10 split-for-spill
] unit-test
! Multiple representations
[
T{ live-interval
{ vreg 5 }
{ reg-class float-regs }
{ start 0 }
{ end 11 }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } }
{ ranges V{ T{ live-range f 0 11 } } }
{ spill-to T{ spill-slot f 16 } }
{ spill-rep double-rep }
}
T{ live-interval
{ vreg 5 }
{ reg-class float-regs }
{ start 20 }
{ end 20 }
{ uses V{ T{ vreg-use f 20 f double-rep } } }
{ ranges V{ T{ live-range f 20 20 } } }
{ reload-from T{ spill-slot f 16 } }
{ reload-rep double-rep }
}
] [
T{ live-interval
{ vreg 5 }
{ reg-class float-regs }
{ start 0 }
{ end 20 }
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } T{ vreg-use f 20 f double-rep } } }
{ ranges V{ T{ live-range f 0 20 } } }
} 15 split-for-spill
] unit-test
H{
{ 1 int-rep }
{ 2 int-rep }
@ -196,7 +257,7 @@ H{
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } }
{ uses V{ T{ vreg-use f 1 int-rep f } T{ vreg-use f 3 f int-rep } T{ vreg-use f 7 f int-rep } T{ vreg-use f 10 f int-rep } T{ vreg-use f 15 f int-rep } } }
}
T{ live-interval
{ vreg 2 }
@ -204,7 +265,7 @@ H{
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } }
{ uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 4 f int-rep } T{ vreg-use f 8 f int-rep } } }
}
T{ live-interval
{ vreg 3 }
@ -212,7 +273,7 @@ H{
{ reg 3 }
{ start 3 }
{ end 10 }
{ uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } }
{ uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 10 f int-rep } } }
}
}
}
@ -223,7 +284,7 @@ H{
{ reg-class int-regs }
{ start 5 }
{ end 5 }
{ uses V{ T{ vreg-use f int-rep 5 } } }
{ uses V{ T{ vreg-use f 5 int-rep f } } }
}
spill-status
] unit-test
@ -243,7 +304,7 @@ H{
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ T{ vreg-use f int-rep 1 } } }
{ uses V{ T{ vreg-use f 1 int-rep f } } }
}
T{ live-interval
{ vreg 2 }
@ -251,7 +312,7 @@ H{
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } }
{ uses V{ T{ vreg-use f 3 int-rep f } T{ vreg-use f 8 f int-rep } } }
}
}
}
@ -262,7 +323,7 @@ H{
{ reg-class int-regs }
{ start 5 }
{ end 5 }
{ uses V{ T{ vreg-use f int-rep 5 } } }
{ uses V{ T{ vreg-use f 5 int-rep f } } }
}
spill-status
] unit-test
@ -276,7 +337,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 0 }
{ end 100 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
}
@ -291,7 +352,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 0 }
{ end 10 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
T{ live-interval
@ -299,7 +360,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 11 }
{ end 20 }
{ uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } }
{ uses V{ T{ vreg-use f 11 int-rep f } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 11 20 } } }
}
}
@ -314,7 +375,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 0 }
{ end 100 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
@ -322,7 +383,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 30 }
{ end 60 }
{ uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } }
{ uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 60 f int-rep } } }
{ ranges V{ T{ live-range f 30 60 } } }
}
}
@ -337,7 +398,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 0 }
{ end 100 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
@ -345,7 +406,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 30 }
{ end 200 }
{ uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } }
{ uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 200 f int-rep } } }
{ ranges V{ T{ live-range f 30 200 } } }
}
}
@ -360,7 +421,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 0 }
{ end 100 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 0 100 } } }
}
T{ live-interval
@ -368,7 +429,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
{ reg-class int-regs }
{ start 30 }
{ end 100 }
{ uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } }
{ uses V{ T{ vreg-use f 30 int-rep f } T{ vreg-use f 100 f int-rep } } }
{ ranges V{ T{ live-range f 30 100 } } }
}
}
@ -392,7 +453,7 @@ H{
{ reg-class int-regs }
{ start 0 }
{ end 20 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
@ -400,7 +461,7 @@ H{
{ reg-class int-regs }
{ start 0 }
{ end 20 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 10 f int-rep } T{ vreg-use f 20 f int-rep } } }
{ ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
}
T{ live-interval
@ -408,7 +469,7 @@ H{
{ reg-class int-regs }
{ start 4 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 6 } } }
{ uses V{ T{ vreg-use f 6 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
T{ live-interval
@ -416,7 +477,7 @@ H{
{ reg-class int-regs }
{ start 4 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 8 } } }
{ uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
@ -426,7 +487,7 @@ H{
{ reg-class int-regs }
{ start 4 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 8 } } }
{ uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 4 8 } } }
}
}
@ -443,7 +504,7 @@ H{
{ reg-class int-regs }
{ start 0 }
{ end 10 }
{ uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } }
{ uses V{ T{ vreg-use f 0 int-rep f } T{ vreg-use f 6 f int-rep } T{ vreg-use f 10 f int-rep } } }
{ ranges V{ T{ live-range f 0 10 } } }
}
@ -453,7 +514,7 @@ H{
{ reg-class int-regs }
{ start 2 }
{ end 8 }
{ uses V{ T{ vreg-use f int-rep 8 } } }
{ uses V{ T{ vreg-use f 8 int-rep f } } }
{ ranges V{ T{ live-range f 2 8 } } }
}
}
@ -595,7 +656,7 @@ H{
{ start 8 }
{ end 10 }
{ ranges V{ T{ live-range f 8 10 } } }
{ uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } }
{ uses V{ T{ vreg-use f 8 int-rep f } T{ vreg-use f 10 f int-rep } } }
}
register-status
] unit-test

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

@ -16,15 +16,13 @@ TUPLE: live-range from to ;
C: <live-range> live-range
SYMBOLS: +def+ +use+ +memory+ ;
TUPLE: vreg-use n def-rep use-rep ;
TUPLE: vreg-use rep n type ;
C: <vreg-use> vreg-use
: <vreg-use> ( n -- vreg-use ) vreg-use new swap >>n ;
TUPLE: live-interval
vreg
reg spill-to reload-from
reg spill-to spill-rep reload-from reload-rep
start end ranges uses
reg-class ;
@ -32,6 +30,15 @@ reg-class ;
: last-use ( live-interval -- use ) uses>> last ; inline
: new-use ( insn# uses -- use )
[ <vreg-use> dup ] dip push ;
: last-use? ( insn# uses -- use/f )
[ drop f ] [ last [ n>> = ] keep and ] if-empty ;
: (add-use) ( insn# live-interval -- use )
uses>> 2dup last-use? dup [ 2nip ] [ drop new-use ] if ;
GENERIC: covers? ( insn# obj -- ? )
M: f covers? 2drop f ;
@ -67,12 +74,6 @@ M: live-interval covers? ( insn# live-interval -- ? )
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
:: add-use ( rep n type live-interval -- )
type +memory+ eq? [
rep n type <vreg-use>
live-interval uses>> push
] unless ;
: <live-interval> ( vreg reg-class -- live-interval )
\ live-interval new
V{ } clone >>uses
@ -97,40 +98,30 @@ GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
:: record-def ( vreg n type -- )
vreg rep-of :> rep
:: record-def ( vreg n -- )
vreg live-interval :> live-interval
n live-interval shorten-range
rep n type live-interval add-use ;
n live-interval (add-use) vreg rep-of >>def-rep drop ;
:: record-use ( vreg n type -- )
vreg rep-of :> rep
:: record-use ( vreg n -- )
vreg live-interval :> live-interval
from get n live-interval add-range
rep n type live-interval add-use ;
n live-interval (add-use) vreg rep-of >>use-rep drop ;
:: record-temp ( vreg n -- )
vreg rep-of :> rep
vreg live-interval :> live-interval
n n live-interval add-range
rep n +def+ live-interval add-use ;
n live-interval (add-use) vreg rep-of >>def-rep drop ;
M:: vreg-insn compute-live-intervals* ( insn -- )
insn insn#>> :> n
insn defs-vreg [ n +def+ record-def ] when*
insn uses-vregs [ n +use+ record-use ] each
insn temp-vregs [ n record-temp ] each ;
M:: clobber-insn compute-live-intervals* ( insn -- )
insn insn#>> :> n
insn defs-vreg [ n +use+ record-def ] when*
insn uses-vregs [ n +memory+ record-use ] each
insn temp-vregs [ n record-temp ] each ;
M: vreg-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vreg ] dip '[ _ record-def ] when* ]
[ [ uses-vregs ] dip '[ _ record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
: handle-live-out ( bb -- )
live-out dup assoc-empty? [ drop ] [

16
basis/compiler/cfg/representations/peephole/peephole.factor
View File

@ -42,8 +42,16 @@ M: ##load-integer optimize-insn
[ call-next-method ]
} cond ;
! When a float is unboxed, we replace the ##load-reference with a ##load-double
! if the architecture supports it
! When a constant float is unboxed, we replace the
! ##load-reference with a ##load-float or ##load-double if the
! architecture supports it
: convert-to-load-float? ( insn -- ? )
{
[ drop fused-unboxing? ]
[ dst>> rep-of float-rep? ]
[ obj>> float? ]
} 1&& ;
: convert-to-load-double? ( insn -- ? )
{
[ drop fused-unboxing? ]
@ -74,6 +82,10 @@ M: ##load-integer optimize-insn
M: ##load-reference optimize-insn
{
{
[ dup convert-to-load-float? ]
[ [ dst>> ] [ obj>> ] bi ##load-float here ]
}
{
[ dup convert-to-load-double? ]
[ [ dst>> ] [ obj>> ] bi ##load-double here ]

13
basis/compiler/cfg/representations/rewrite/rewrite.factor
View File

@ -90,15 +90,14 @@ M: ##copy conversions-for-insn , ;
M: insn conversions-for-insn , ;
: conversions-for-block ( bb -- )
dup kill-block? [ drop ] [
[
[
[
H{ } clone alternatives set
[ conversions-for-insn ] each
] V{ } make
] change-instructions drop
] if ;
alternatives get clear-assoc
[ conversions-for-insn ] each
] V{ } make
] change-instructions drop ;
: insert-conversions ( cfg -- )
H{ } clone alternatives set
V{ } clone renaming-set set
[ conversions-for-block ] each-basic-block ;

6
basis/compiler/cfg/rpo/rpo.factor
View File

@ -36,8 +36,10 @@ SYMBOL: visited
[ reverse-post-order ] dip each ; inline
: optimize-basic-block ( bb quot -- )
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
over kill-block?>> [ 2drop ] [
over basic-block set
change-instructions drop
] if ; inline
: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
'[ _ optimize-basic-block ] each-basic-block ; inline

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

@ -1,9 +1,10 @@
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs compiler.cfg.def-use
compiler.cfg.dependence compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.rpo cpu.architecture fry
kernel locals make math namespaces sequences sets ;
USING: accessors arrays assocs fry kernel locals make math
namespaces sequences sets combinators.short-circuit
compiler.cfg.def-use compiler.cfg.dependence
compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo
cpu.architecture ;
IN: compiler.cfg.scheduling
! Instruction scheduling to reduce register pressure, from:
@ -128,7 +129,6 @@ ERROR: definition-after-usage vreg old-bb new-bb ;
: schedule-instructions ( cfg -- cfg' )
dup [
dup might-spill?
[ schedule-block ]
[ drop ] if
dup { [ kill-block?>> not ] [ might-spill? ] } 1&&
[ schedule-block ] [ drop ] if
] each-basic-block ;

2
basis/compiler/cfg/stacks/finalize/finalize.factor
View File

@ -43,7 +43,7 @@ ERROR: bad-peek dst loc ;
: visit-edge ( from to -- )
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
2dup [ kill-block?>> ] both? [ 2drop ] [
2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
[ 2drop ] [ insert-basic-block ] if-empty
] if ;

6
basis/compiler/cfg/utilities/utilities.factor
View File

@ -6,12 +6,6 @@ sets vectors fry arrays compiler.cfg compiler.cfg.instructions
compiler.cfg.rpo compiler.utilities ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
instructions>> {
[ length 2 >= ]
[ penultimate kill-vreg-insn? ]
} 1&& ;
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;

207
basis/compiler/codegen/alien/alien.factor
View File

@ -1,207 +0,0 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.complex alien.c-types
alien.libraries alien.private alien.strings arrays
classes.struct combinators compiler.alien
compiler.cfg.instructions compiler.codegen
compiler.codegen.fixup compiler.errors compiler.utilities
cpu.architecture fry kernel layouts libc locals make math
math.order math.parser namespaces quotations sequences strings
system ;
FROM: compiler.errors => no-such-symbol ;
IN: compiler.codegen.alien
! ##alien-invoke
GENERIC: next-fastcall-param ( rep -- )
: ?dummy-stack-params ( rep -- )
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( rep -- )
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
: ?dummy-fp-params ( rep -- )
drop dummy-fp-params? [ float-regs inc ] when ;
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
M: stack-params reg-class-full? 2drop t ;
M: reg-class reg-class-full?
[ get ] swap '[ _ param-regs length ] bi >= ;
: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
[ rep-size cell align stack-params +@ ] dip
stack-params dup ;
: alloc-fastcall-param ( rep -- n reg-class rep )
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
:: alloc-parameter ( rep abi -- reg rep )
rep dup reg-class-of abi reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
[ abi param-reg ] dip ;
: reset-fastcall-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
: with-param-regs ( quot -- )
#! In quot you can call alloc-parameter
[ reset-fastcall-counts call ] with-scope ; inline
:: move-parameters ( params 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).
0 params alien-parameters flatten-c-types [
[ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
[ rep-size cell align + ]
2bi
] each drop ; inline
: parameter-offsets ( types -- offsets )
0 [ stack-size + ] accumulate nip ;
: each-parameter ( parameters quot -- )
[ [ parameter-offsets ] keep ] dip 2each ; inline
: reverse-each-parameter ( parameters quot -- )
[ [ parameter-offsets ] keep ] dip 2reverse-each ; inline
: prepare-unbox-parameters ( parameters -- offsets types indices )
[ parameter-offsets ] [ ] [ length iota <reversed> ] tri ;
: unbox-parameters ( offset node -- )
parameters>> swap
'[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
[ length neg %inc-d ]
bi ;
: 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 registers 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 %push-stack ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
M: string dlsym-valid? dlsym ;
M: array dlsym-valid? '[ _ dlsym ] any? ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd dlsym-valid?
[ drop ] [ compiling-word get no-such-symbol ] if
] [
dll-path compiling-word get no-such-library drop
] if ;
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
M: ##alien-invoke generate-insn
params>>
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call function
dup alien-invoke-dlsym %alien-invoke
! Box return value
dup %cleanup
box-return* ;
M: ##alien-assembly generate-insn
params>>
! Unbox parameters
dup objects>registers
%prepare-var-args
! Generate assembly
dup quot>> call( -- )
! Box return value
box-return* ;
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
! Unbox parameters
dup objects>registers
%prepare-var-args
! Call alien in temporary storage
%alien-indirect
! Box return value
dup %cleanup
box-return* ;
! ##alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
: registers>objects ( node -- )
! Generate code for boxing input parameters in a callback.
[
dup \ %save-param-reg move-parameters
%begin-callback
box-parameters
] with-param-regs ;
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup void? ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
[ 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
yield-hook get
'[ _ _ do-callback ]
>quotation ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;

1
basis/compiler/codegen/alien/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

14
basis/compiler/codegen/codegen-tests.factor
View File

@ -2,13 +2,13 @@ USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
compiler.constants words ;
IN: compiler.codegen.tests
[ ] [ gensym [ ] with-fixup drop ] unit-test
[ ] [ gensym [ \ + %call ] with-fixup drop ] unit-test
[ ] [ [ ] with-fixup drop ] unit-test
[ ] [ [ \ + %call ] with-fixup drop ] unit-test
[ ] [ gensym [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ gensym [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
! Error checking
[ gensym [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ gensym [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

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

@ -82,7 +82,7 @@ M: ##dispatch generate-insn
] tri ;
: generate ( cfg -- code )
dup label>> [
[
H{ } clone labels set
linearization-order
[ number-blocks ] [ [ generate-block ] each ] bi
@ -91,6 +91,8 @@ M: ##dispatch generate-insn
! Special cases
M: ##no-tco generate-insn drop ;
M: ##stack-frame generate-insn drop ;
M: ##prologue generate-insn
drop
cfg get stack-frame>>
@ -122,6 +124,7 @@ SYNTAX: CODEGEN:
CODEGEN: ##load-integer %load-immediate
CODEGEN: ##load-tagged %load-immediate
CODEGEN: ##load-reference %load-reference
CODEGEN: ##load-float %load-float
CODEGEN: ##load-double %load-double
CODEGEN: ##load-vector %load-vector
CODEGEN: ##peek %peek
@ -243,6 +246,7 @@ CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
@ -250,6 +254,7 @@ CODEGEN: ##call-gc %call-gc
CODEGEN: ##spill %spill
CODEGEN: ##reload %reload
! Conditional branches
<<
SYNTAX: CONDITIONAL:
@ -269,3 +274,24 @@ CONDITIONAL: ##check-nursery-branch %check-nursery-branch
CONDITIONAL: ##fixnum-add %fixnum-add
CONDITIONAL: ##fixnum-sub %fixnum-sub
CONDITIONAL: ##fixnum-mul %fixnum-mul
! FFI
CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long
CODEGEN: ##box-large-struct %box-large-struct
CODEGEN: ##box-small-struct %box-small-struct
CODEGEN: ##unbox %unbox
CODEGEN: ##unbox-long-long %unbox-long-long
CODEGEN: ##unbox-large-struct %unbox-large-struct
CODEGEN: ##unbox-small-struct %unbox-small-struct
CODEGEN: ##prepare-box-struct %prepare-box-struct
CODEGEN: ##load-param-reg %load-param-reg
CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect
CODEGEN: ##save-param-reg %save-param-reg
CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
M: ##alien-assembly generate-insn quot>> call( -- ) ;

23
basis/compiler/codegen/fixup/fixup.factor
View File

@ -12,13 +12,6 @@ IN: compiler.codegen.fixup
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
: push-double ( value vector -- )
[ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-double ;
! Owner
SYMBOL: compiling-word
! Parameter table
SYMBOL: parameter-table
@ -119,8 +112,7 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
[ [ compute-relative-label ] map concat ]
bi* ;
: init-fixup ( word -- )
compiling-word set
: init-fixup ( -- )
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
@ -136,22 +128,15 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: align-code ( n -- )
alignment (align-code) ;
GENERIC# emit-data 1 ( obj label -- )
M: float emit-data
8 align-code
resolve-label
building get push-double ;
M: byte-array emit-data
16 align-code
: emit-data ( obj label -- )
over length align-code
resolve-label
building get push-all ;
: emit-binary-literals ( -- )
binary-literal-table get [ emit-data ] assoc-each ;
: with-fixup ( word quot -- code )
: with-fixup ( quot -- code )
'[
init-fixup
@

4
basis/compiler/compiler.factor
View File

@ -15,11 +15,11 @@ compiler.tree.optimizer
compiler.cfg
compiler.cfg.builder
compiler.cfg.builder.alien
compiler.cfg.optimizer
compiler.cfg.finalization
compiler.codegen
compiler.codegen.alien ;
compiler.codegen ;
IN: compiler
SYMBOL: compiled

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

@ -99,8 +99,6 @@ FUNCTION: TINY ffi_test_17 int x ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
@ -610,11 +608,6 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
[ 100 ] [ "p" get ?promise ] unit-test
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;

21
basis/compiler/tests/linkage-errors.factor Normal file
View File

@ -0,0 +1,21 @@
USING: tools.test namespaces assocs alien.syntax kernel
compiler.errors accessors alien ;
FROM: alien.libraries => add-library ;
IN: compiler.tests.linkage-errors
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
[ T{ no-such-symbol { name "this_does_not_exist" } } ]
[ \ this_does_not_exist linkage-errors get at error>> ] unit-test
<< "no_such_library" "no_such_library" cdecl add-library >>
LIBRARY: no_such_library
FUNCTION: void no_such_function ( ) ;
[ T{ no-such-library { name "no_such_library" } } ]
[ \ no_such_function linkage-errors get at error>> ] unit-test

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

@ -224,6 +224,7 @@ HOOK: complex-addressing? cpu ( -- ? )
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-float cpu ( reg val -- )
HOOK: %load-double cpu ( reg val -- )
HOOK: %load-vector cpu ( reg val rep -- )
@ -504,8 +505,8 @@ M: reg-class param-reg param-regs nth ;
M: stack-params param-reg 2drop ;
! Does this architecture support %load-double, %load-vector and
! objects in %compare-imm?
! Does this architecture support %load-float, %load-double,
! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? )
! Can this value be an immediate operand for %add-imm, %sub-imm,
@ -552,48 +553,28 @@ HOOK: dummy-int-params? cpu ( -- ? )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
! Load a value (from the data stack in the ds register).
! The value is then passed as a parameter to a VM to_*() function
HOOK: %pop-stack cpu ( n -- )
! Call a function to convert a tagged pointer into a value that
! can be passed to a C function, or returned from a callback
HOOK: %unbox cpu ( src n rep func -- )
! Store a value (to the data stack in the VM's current context)
! The value is passed to a VM to_*() function -- used for
! callback returns
HOOK: %pop-context-stack cpu ( -- )
HOOK: %unbox-long-long cpu ( src n func -- )
! Store a value (to the data stack in the ds register).
! The value was returned from a VM from_*() function
HOOK: %push-stack cpu ( -- )
HOOK: %unbox-small-struct cpu ( src c-type -- )
! Store a value (to the data stack in the VM's current context)
! The value is returned from a VM from_*() function -- used for
! callback parameters
HOOK: %push-context-stack cpu ( -- )
! Call a function to convert a tagged pointer returned by
! %pop-stack or %pop-context-stack into a value that can be
! passed to a C function, or returned from a callback
HOOK: %unbox cpu ( n rep func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct cpu ( c-type -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
HOOK: %unbox-large-struct cpu ( src n c-type -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack by %push-stack or
! %push-context-stack
HOOK: %box cpu ( n rep func -- )
! which is then pushed on the data stack
HOOK: %box cpu ( dst n rep func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %box-long-long cpu ( dst n func -- )
HOOK: %prepare-box-struct cpu ( -- )
HOOK: %box-small-struct cpu ( c-type -- )
HOOK: %box-small-struct cpu ( dst c-type -- )
HOOK: %box-large-struct cpu ( n c-type -- )
HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
@ -603,19 +584,13 @@ HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( -- )
HOOK: %alien-indirect cpu ( src -- )
HOOK: %begin-callback cpu ( -- )
@ -623,8 +598,6 @@ HOOK: %alien-callback cpu ( quot -- )
HOOK: %end-callback cpu ( -- )
HOOK: %end-callback-value cpu ( c-type -- )
HOOK: stack-cleanup cpu ( params -- n )
M: object stack-cleanup drop 0 ;

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

@ -677,69 +677,55 @@ M:: ppc %save-param-reg ( stack reg rep -- )
M:: ppc %load-param-reg ( stack reg rep -- )
reg stack local@ rep load-from-frame ;
M: ppc %pop-stack ( n -- )
[ 3 ] dip <ds-loc> loc>operand LWZ ;
GENERIC: load-param ( reg src -- )
M: ppc %push-stack ( -- )
ds-reg ds-reg 4 ADDI
int-regs return-reg ds-reg 0 STW ;
M: integer load-param int-rep %copy ;
M: ppc %push-context-stack ( -- )
11 %context
12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: spill-slot load-param n>> spill@ LWZ ;
M: ppc %pop-context-stack ( -- )
11 %context
12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
12 11 "datastack" context-field-offset STW ;
GENERIC: store-param ( reg dst -- )
M: ppc %unbox ( n rep func -- )
! Value must be in r3
M: integer store-param swap int-rep %copy ;
M: spill-slot store-param n>> spill@ STW ;
:: call-unbox-func ( src func -- )
3 src load-param
4 %load-vm-addr
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ reg-class-of return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc %unbox-long-long ( n func -- )
4 %load-vm-addr
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
[
[ [ 3 1 ] dip local@ STW ]
[ [ 4 1 ] dip cell + local@ STW ] bi
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
[ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
6 %load-vm-addr
! Call the function
"to_value_struct" f %alien-invoke ;
M:: ppc %box ( n rep func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
func f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
[
[
[ [ 3 1 ] dip local@ LWZ ]
[ [ 4 1 ] dip cell + local@ LWZ ] bi
] when*
5 %load-vm-addr
] dip f %alien-invoke ;
M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func
! Store the return value on the C stack
n [ rep reg-class-of return-reg rep %save-param-reg ] when* ;
M:: ppc %unbox-long-long ( src n func -- )
src func call-unbox-func
! Store the return value on the C stack
n [
3 1 n local@ STW
4 1 n cell + local@ STW
] when ;
M:: ppc %unbox-large-struct ( src n c-type -- )
4 src load-param
3 1 n local@ ADDI
heap-size 5 LI
"memcpy" "libc" load-library %alien-invoke ;
M:: ppc %box ( dst n rep func -- )
n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
func f %alien-invoke
3 dst store-param ;
M:: ppc %box-long-long ( dst n func -- )
n [
3 1 n local@ LWZ
4 1 n cell + local@ LWZ
] when
func f %alien-invoke
3 dst store-param ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
@ -749,13 +735,15 @@ M: ppc %prepare-box-struct ( -- )
3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
M:: ppc %box-large-struct ( dst n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
[ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
3 1 n struct-return@ ADDI
c-type heap-size 4 LI
5 %load-vm-addr
! Call the function
"from_value_struct" f %alien-invoke ;
"from_value_struct" f %alien-invoke
3 dst store-param ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 %context
@ -771,15 +759,8 @@ M:: ppc %save-context ( temp1 temp2 -- )
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %prepare-alien-indirect ( -- )
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
4 %load-vm-addr
"pinned_alien_offset" f %alien-invoke
16 3 MR ;
M: ppc %alien-indirect ( -- )
16 MTLR BLRL ;
M: ppc %alien-indirect ( src -- )
[ 11 ] dip load-param 11 MTLR BLRL ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
@ -792,66 +773,51 @@ M: ppc struct-return-pointer-type void* ;
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
M: ppc %box-small-struct ( c-type -- )
M:: ppc %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
heap-size 7 LI
c-type heap-size 7 LI
8 %load-vm-addr
"from_medium_struct" f %alien-invoke ;
"from_medium_struct" f %alien-invoke
3 dst store-param ;
: %unbox-struct-1 ( -- )
! Alien must be in r3.
4 %load-vm-addr
"alien_offset" f %alien-invoke
3 3 0 LWZ ;
: %unbox-struct-2 ( -- )
! Alien must be in r3.
4 %load-vm-addr
"alien_offset" f %alien-invoke
4 3 4 LWZ
3 3 0 LWZ ;
: %unbox-struct-4 ( -- )
! Alien must be in r3.
4 %load-vm-addr
"alien_offset" f %alien-invoke
6 3 12 LWZ
5 3 8 LWZ
4 3 4 LWZ
3 3 0 LWZ ;
M:: ppc %unbox-small-struct ( src c-type -- )
src 3 load-param
c-type heap-size {
{ [ dup 4 <= ] [ drop %unbox-struct-1 ] }
{ [ dup 8 <= ] [ drop %unbox-struct-2 ] }
{ [ dup 16 <= ] [ drop %unbox-struct-4 ] }
} cond ;
M: ppc %begin-callback ( -- )
3 %load-vm-addr
"begin_callback" f %alien-invoke ;
M: ppc %alien-callback ( quot -- )
3 4 %restore-context
3 swap %load-reference
4 3 quot-entry-point-offset LWZ
4 MTLR
BLRL
3 4 %save-context ;
BLRL ;
M: ppc %end-callback ( -- )
3 %load-vm-addr
"end_callback" f %alien-invoke ;
M: ppc %end-callback-value ( ctype -- )
! Save top of data stack
16 ds-reg 0 LWZ
%end-callback
! Restore top of data stack
3 16 MR
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
{ 4 [ %unbox-struct-4 ] }
} case ;
enable-float-functions
USE: vocabs.loader

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

@ -5,8 +5,8 @@ arrays kernel fry math namespaces sequences system layouts io
vocabs.loader accessors init classes.struct combinators
command-line make words compiler compiler.units
compiler.constants compiler.alien compiler.codegen
compiler.codegen.alien compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.codegen.fixup compiler.cfg.instructions
compiler.cfg.builder compiler.cfg.builder.alien
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture vm ;
@ -27,12 +27,15 @@ M: x86.32 temp-reg ECX ;
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M: x86.32 %load-double ( dst val -- )
[ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
M: x86.32 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.32 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
@ -148,31 +151,34 @@ M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( n rep func -- )
M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
func f %alien-invoke ;
func f %alien-invoke
dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- )
[
EDX over next-stack@ MOV
EAX swap cell - next-stack@ MOV
[ EDX swap next-stack@ MOV ]
[ EAX swap cell - next-stack@ MOV ] bi
] when* ;
M: x86.32 %box-long-long ( n func -- )
[ (%box-long-long) ] dip
M:: x86.32 %box-long-long ( dst n func -- )
n (%box-long-long)
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
f %alien-invoke ;
func f %alien-invoke
dst EAX tagged-rep %copy ;
M:: x86.32 %box-large-struct ( n c-type -- )
M:: x86.32 %box-large-struct ( dst n c-type -- )
EDX n struct-return@ LEA
8 save-vm-ptr
4 stack@ c-type heap-size MOV
0 stack@ EDX MOV
"from_value_struct" f %alien-invoke ;
"from_value_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
@ -180,115 +186,68 @@ M: x86.32 %prepare-box-struct ( -- )
! Store it as the first parameter
0 local@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
M:: x86.32 %box-small-struct ( dst c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 save-vm-ptr
8 stack@ swap heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"from_small_struct" f %alien-invoke ;
M: x86.32 %pop-stack ( n -- )
EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- )
temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
: call-unbox-func ( func -- )
4 save-vm-ptr
0 stack@ EAX MOV
f %alien-invoke ;
M: x86.32 %unbox ( n rep func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
call-unbox-func
! Store the return value on the C stack
over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
call-unbox-func
! Store the return value on the C stack
[
[ local@ EAX MOV ]
[ 4 + local@ EDX MOV ] bi
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 save-vm-ptr
0 stack@ EAX MOV
"alien_offset" f %alien-invoke
! Load first cell
EAX EAX [] MOV ;
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 save-vm-ptr
0 stack@ EAX MOV
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M:: x86.32 %unbox-large-struct ( n c-type -- )
! Alien must be in EAX.
! Compute destination address
EDX n local@ LEA
12 save-vm-ptr
8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"to_value_struct" f %alien-invoke ;
"from_small_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
M: x86.32 %prepare-alien-indirect ( -- )
EAX ds-reg [] MOV
ds-reg 4 SUB
:: call-unbox-func ( src func -- )
EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
"pinned_alien_offset" f %alien-invoke
EBP EAX MOV ;
func f %alien-invoke ;
M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M:: x86.32 %unbox ( src n rep func -- )
! If n is f, we're unboxing a return value about to be
! returned by the callback. Otherwise, we're unboxing
! a parameter to a C function about to be called.
src func call-unbox-func
! Store the return value on the C stack
n [ n local@ rep store-return-reg ] when ;
M:: x86.32 %unbox-long-long ( src n func -- )
src func call-unbox-func
! Store the return value on the C stack
n [
[ local@ EAX MOV ]
[ 4 + local@ EDX MOV ] bi
] when* ;
M: x86 %unbox-small-struct ( src size -- )
[ [ EAX ] dip int-rep %copy ]
[
heap-size 4 > [ EDX EAX 4 [+] MOV ] when
EAX EAX [] MOV
] bi* ;
M:: x86.32 %unbox-large-struct ( src n c-type -- )
EAX src int-rep %copy
EDX n local@ LEA
8 stack@ c-type heap-size MOV
4 stack@ EAX MOV
0 stack@ EDX MOV
"memcpy" "libc" load-library %alien-invoke ;
M: x86.32 %alien-indirect ( src -- )
?spill-slot CALL ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
ESP 4 [+] 0 MOV
4 stack@ 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
EAX EDX %restore-context
EAX swap %load-reference
EAX quot-entry-point-offset [+] CALL
EAX EDX %save-context ;
[ EAX ] dip %load-reference
EAX quot-entry-point-offset [+] CALL ;
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
"end_callback" f %alien-invoke ;
M: x86.32 %end-callback-value ( ctype -- )
%pop-context-stack
4 stack@ EAX MOV
%end-callback
! Place former top of data stack back in EAX
EAX 4 stack@ MOV
! Unbox EAX
unbox-return ;
GENERIC: float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )

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

@ -46,12 +46,15 @@ M: x86.64 %mov-vm-ptr ( reg -- )
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
M: x86.64 %load-double ( dst val -- )
[ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
M: x86.64 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.64 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
@ -114,16 +117,8 @@ M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
call
] with-scope ; inline
M: x86.64 %pop-stack ( n -- )
param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- )
temp-reg %context
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
M:: x86.64 %unbox ( n rep func -- )
M:: x86.64 %unbox ( src n rep func -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
! Call the unboxer
func f %alien-invoke
@ -133,32 +128,24 @@ M:: x86.64 %unbox ( n rep func -- )
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
: %unbox-struct-field ( rep i -- )
! Alien must be in param-reg-0.
R11 swap cells [+] swap reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in param-reg-0.
param-reg-1 %mov-vm-ptr
"alien_offset" f %alien-invoke
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
M:: x86.64 %unbox-small-struct ( src c-type -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
[
flatten-struct-type [ %unbox-struct-field ] each-index
c-type flatten-struct-type
[ %unbox-struct-field ] each-index
] with-return-regs ;
M:: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in param-reg-0
! Load destination address into param-reg-1
param-reg-1 n param@ LEA
! Load structure size into param-reg-2
M:: x86.64 %unbox-large-struct ( src n c-type -- )
param-reg-1 src int-rep %copy
param-reg-0 n param@ LEA
param-reg-2 c-type heap-size MOV
param-reg-3 %mov-vm-ptr
! Copy the struct to the C stack
"to_value_struct" f %alien-invoke ;
"memcpy" "libc" load-library %alien-invoke ;
: load-return-value ( rep -- )
[ [ 0 ] dip reg-class-of cdecl param-reg ]
@ -166,7 +153,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
[ ]
tri %copy ;
M:: x86.64 %box ( n rep func -- )
M:: x86.64 %box ( dst n rep func -- )
n [
n
0 rep reg-class-of cdecl param-reg
@ -175,7 +162,8 @@ M:: x86.64 %box ( n rep func -- )
rep load-return-value
] if
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke ;
func f %alien-invoke
dst RAX tagged-rep %copy ;
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
@ -185,28 +173,30 @@ M:: x86.64 %box ( n rep func -- )
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
[
[ flatten-struct-type [ %box-struct-field ] each-index ]
[ param-reg-2 swap heap-size MOV ] bi
c-type flatten-struct-type [ %box-struct-field ] each-index
param-reg-2 c-type heap-size MOV
param-reg-0 0 box-struct-field@ MOV
param-reg-1 1 box-struct-field@ MOV
param-reg-3 %mov-vm-ptr
"from_small_struct" f %alien-invoke
dst RAX tagged-rep %copy
] with-return-regs ;
: struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
M: x86.64 %box-large-struct ( n c-type -- )
M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
param-reg-1 swap heap-size MOV
param-reg-1 c-type heap-size MOV
! Compute destination address
param-reg-0 swap struct-return@ LEA
param-reg-0 n struct-return@ LEA
param-reg-2 %mov-vm-ptr
! Copy the struct from the C stack
"from_value_struct" f %alien-invoke ;
"from_value_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
@ -214,22 +204,13 @@ M: x86.64 %prepare-box-struct ( -- )
! Store it as the first parameter
0 param@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
param-reg-0 ds-reg [] MOV
ds-reg 8 SUB
param-reg-1 %mov-vm-ptr
"pinned_alien_offset" f %alien-invoke
nv-reg RAX MOV ;
M: x86.64 %alien-indirect ( -- )
nv-reg CALL ;
M: x86.64 %alien-indirect ( src -- )
?spill-slot CALL ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
@ -237,23 +218,13 @@ M: x86.64 %begin-callback ( -- )
"begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
param-reg-0 param-reg-1 %restore-context
param-reg-0 swap %load-reference
param-reg-0 quot-entry-point-offset [+] CALL
param-reg-0 param-reg-1 %save-context ;
[ param-reg-0 ] dip %load-reference
param-reg-0 quot-entry-point-offset [+] CALL ;
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
"end_callback" f %alien-invoke ;
M: x86.64 %end-callback-value ( ctype -- )
%pop-context-stack
nv-reg param-reg-0 MOV
%end-callback
param-reg-0 nv-reg MOV
! Unbox former top of data stack to return registers
unbox-return ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;

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

@ -3,7 +3,7 @@
USING: accessors arrays sequences math splitting make assocs
kernel layouts system alien.c-types classes.struct
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
cpu.x86 compiler.codegen.alien compiler.cfg.registers ;
cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ;
IN: cpu.x86.64.unix
M: int-regs param-regs

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

@ -180,9 +180,11 @@ M: object copy-memory* copy-register* ;
M: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
[ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
@ -502,16 +504,6 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
M: x86 %push-stack ( -- )
ds-reg cell ADD
ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- )
temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: (%boolean) ( dst temp insn -- )

13
basis/stack-checker/alien/alien.factor
View File

@ -20,9 +20,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
: infer-params ( params -- )
param-prep-quot infer-quot-here ;
: alien-stack ( params extra -- )
over parameters>> length + consume-d >>in-d
dup return>> void? 0 1 ? produce-d >>out-d
@ -62,7 +59,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
! Set ABI
dup library>> library-abi >>abi
! Quotation which coerces parameters to required types
dup infer-params
dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
@ -76,10 +73,8 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-abi
pop-params
pop-return
! Quotation which coerces parameters to required types
1 infer->r
dup infer-params
1 infer-r>
! Coerce parameters to required types
dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
@ -95,7 +90,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-params
pop-return
! Quotation which coerces parameters to required types
dup infer-params
dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR

2
basis/ui/backend/windows/windows.factor
View File

@ -476,7 +476,7 @@ SYMBOL: nc-buttons
swap [ push ] [ remove! drop ] if ;
: mouse-scroll ( wParam -- array )
>lo-hi [ -120 /f ] map ;
>lo-hi [ -80 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button

9
core/sequences/sequences-docs.factor
View File

@ -1200,15 +1200,6 @@ HELP: 2selector
{ "selector" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
HELP: 2reverse-each
{ $values
{ "seq1" sequence } { "seq2" sequence } { "quot" quotation } }
{ $description "Reverse the sequences using the " { $link <reversed> } " word and calls " { $link 2each } " on the reversed sequences." }
{ $examples { $example "USING: sequences math prettyprint ;"
"{ 10 20 30 } { 1 2 3 } [ + . ] 2reverse-each"
"33\n22\n11"
} } ;
HELP: 2unclip-slice
{ $values
{ "seq1" sequence } { "seq2" sequence }

3
core/sequences/sequences.factor
View File

@ -444,9 +444,6 @@ PRIVATE>
: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline

2
extra/compiler/graphviz/graphviz.factor
View File

@ -58,7 +58,7 @@ IN: compiler.graphviz
: cfg-vertex, ( bb -- )
[ number>> number>string ]
[ kill-block? { "color=grey" "style=filled" } { } ? ]
[ kill-block?>> { "color=grey" "style=filled" } { } ? ]
bi node-style, ;
: cfgs ( cfgs -- )

11
vm/alien.cpp
View File

@ -187,17 +187,6 @@ VM_C_API char *alien_offset(cell obj, factor_vm *parent)
return parent->alien_offset(obj);
}
/* For FFI calls passing structs by value. Cannot allocate */
void factor_vm::to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *parent)
{
return parent->to_value_struct(src,dest,size);
}
/* For FFI callbacks receiving structs by value */
cell factor_vm::from_value_struct(void *src, cell size)
{

1
vm/alien.hpp
View File

@ -4,7 +4,6 @@ namespace factor
VM_C_API char *alien_offset(cell object, factor_vm *vm);
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
VM_C_API cell allot_alien(void *address, factor_vm *vm);
VM_C_API void to_value_struct(cell src, void *dest, cell size, factor_vm *vm);
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *vm);
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *vm);
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *vm);

1
vm/vm.hpp
View File

@ -615,7 +615,6 @@ struct factor_vm
void primitive_dlclose();
void primitive_dll_validp();
char *alien_offset(cell obj);
void to_value_struct(cell src, void *dest, cell size);
cell from_value_struct(void *src, cell size);
cell from_small_struct(cell x, cell y, cell size);
cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);