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

FFI rewrite part 1: split up ##alien-invoke and friends into smaller instructions

db4
Slava Pestov 2010-05-09 21:36:52 -04:00
parent fa99cc8f0e
commit c211c3e84e
33 changed files with 506 additions and 495 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 ;

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

@ -0,0 +1,293 @@
! 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 ;
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 ;
: 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 ;
GENERIC: unbox-parameter ( 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-large-struct ] [ base-type unbox-parameter ] if-value-struct ;
: unbox-parameters ( offset node -- )
parameters>> swap
'[
prepare-unbox-parameters
[ ##pop-stack [ _ + ] dip base-type 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 -- )
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 ##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 ] [ 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
[
! Save alien at top of stack to temporary storage
##prepare-alien-indirect
! Unbox parameters
dup objects>registers
! Call alien in temporary storage
##alien-indirect
! Box return value
dup ##cleanup
box-return*
] emit-alien-node ;
M: #alien-assembly emit-node
[
! Unbox parameters
dup objects>registers
! Generate assembly
dup quot>> ##alien-assembly
! Box return value
box-return*
] emit-alien-node ;
GENERIC: box-parameter ( n c-type -- )
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
[ base-type 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 ;
GENERIC: unbox-return ( 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-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 ] [
##pop-context-stack
##to-nv
##end-callback
##from-nv
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

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

@ -609,17 +609,73 @@ use: src/tagged-rep
literal: offset ;
! FFI
INSN: ##alien-invoke
literal: params stack-frame ;
INSN: ##stack-frame
literal: stack-frame ;
INSN: ##alien-indirect
literal: params stack-frame ;
INSN: ##box
literal: n rep boxer ;
INSN: ##box-long-long
literal: n boxer ;
INSN: ##box-small-struct
literal: c-type ;
INSN: ##box-large-struct
literal: n c-type ;
INSN: ##unbox
literal: n rep unboxer ;
INSN: ##unbox-long-long
literal: n unboxer ;
INSN: ##unbox-large-struct
literal: n c-type ;
INSN: ##unbox-small-struct
literal: c-type ;
INSN: ##pop-stack
literal: n ;
INSN: ##pop-context-stack ;
INSN: ##prepare-box-struct ;
INSN: ##load-param-reg
literal: offset reg rep ;
INSN: ##push-stack ;
INSN: ##alien-invoke
literal: symbols dll ;
INSN: ##cleanup
literal: params ;
INSN: ##prepare-alien-indirect ;
INSN: ##alien-indirect ;
INSN: ##alien-assembly
literal: params stack-frame ;
literal: quot ;
INSN: ##push-context-stack ;
INSN: ##save-param-reg
literal: offset reg rep ;
INSN: ##begin-callback ;
INSN: ##alien-callback
literal: params stack-frame ;
literal: quot ;
INSN: ##end-callback ;
INSN: ##to-nv ;
INSN: ##from-nv ;
! Control flow
INSN: ##phi
@ -758,15 +814,6 @@ UNION: clobber-insn
##unary-float-function
##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
##prologue
##epilogue
##alien-invoke
##alien-indirect
##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn

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

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

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

@ -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>>
@ -251,6 +253,7 @@ CODEGEN: ##call-gc %call-gc
CODEGEN: ##spill %spill
CODEGEN: ##reload %reload
! Conditional branches
<<
SYNTAX: CONDITIONAL:
@ -270,3 +273,31 @@ 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: ##pop-stack %pop-stack
CODEGEN: ##pop-context-stack %pop-context-stack
CODEGEN: ##prepare-box-struct %prepare-box-struct
CODEGEN: ##load-param-reg %load-param-reg
CODEGEN: ##push-stack %push-stack
CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup
CODEGEN: ##prepare-alien-indirect %prepare-alien-indirect
CODEGEN: ##alien-indirect %alien-indirect
CODEGEN: ##push-context-stack %push-context-stack
CODEGEN: ##save-param-reg %save-param-reg
CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
CODEGEN: ##to-nv %to-nv
CODEGEN: ##from-nv %from-nv
M: ##alien-assembly generate-insn quot>> call( -- ) ;

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

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

@ -610,11 +610,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

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

@ -624,7 +624,9 @@ HOOK: %alien-callback cpu ( quot -- )
HOOK: %end-callback cpu ( -- )
HOOK: %end-callback-value cpu ( c-type -- )
HOOK: %to-nv cpu ( -- )
HOOK: %from-nv cpu ( -- )
HOOK: stack-cleanup cpu ( params -- n )

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

@ -836,14 +836,9 @@ 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 %to-nv ( -- ) 16 3 MR ;
M: ppc %from-nv ( -- ) 3 16 MR ;
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {

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

@ -283,14 +283,9 @@ 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 ;
M: x86.32 %to-nv ( -- ) 4 stack@ EAX MOV ;
M: x86.32 %from-nv ( -- ) EAX 4 stack@ MOV ;
GENERIC: float-function-param ( stack-slot dst src -- )

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

@ -249,13 +249,9 @@ 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 ;
M: x86.64 %to-nv ( -- ) nv-reg param-reg-0 MOV ;
M: x86.64 %from-nv ( -- ) param-reg-0 nv-reg MOV ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;