Debugging front-end, updating FFI codegen
Slava Pestov
parent
aededc406f
commit
762007b28e
|
|
@ -2,8 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes combinators
|
||||
cpu.architecture effects generic hashtables io kernel
|
||||
kernel.private layouts math namespaces prettyprint quotations
|
||||
sequences system threads words vectors sets dequeues cursors
|
||||
kernel.private layouts math math.parser namespaces prettyprint
|
||||
quotations sequences system threads words vectors sets dequeues
|
||||
cursors continuations.private summary alien alien.c-types
|
||||
alien.structs alien.strings alien.arrays libc compiler.errors
|
||||
stack-checker.inlining
|
||||
compiler.tree compiler.tree.builder compiler.tree.combinators
|
||||
compiler.tree.propagation.info compiler.generator.fixup
|
||||
|
|
@ -48,7 +50,7 @@ SYMBOL: current-label-start
|
|||
: save-machine-code ( literals relocation labels code -- )
|
||||
4array compiling-label get compiled get set-at ;
|
||||
|
||||
: with-generator ( node word label quot -- )
|
||||
: with-generator ( nodes word label quot -- )
|
||||
[
|
||||
>r begin-compiling r>
|
||||
{ } make fixup
|
||||
|
|
@ -267,3 +269,316 @@ M: #return-recursive generate-node
|
|||
end-basic-block
|
||||
label>> id>> compiling-loops get key?
|
||||
[ %return ] unless f ;
|
||||
|
||||
! #alien-invoke
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
|
||||
: alien-return ( params -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||
|
||||
: parameter-align ( n type -- n delta )
|
||||
over >r c-type-stack-align align dup r> - ;
|
||||
|
||||
: parameter-sizes ( types -- total offsets )
|
||||
#! Compute stack frame locations.
|
||||
[
|
||||
0 [
|
||||
[ parameter-align drop dup , ] keep stack-size +
|
||||
] reduce cell align
|
||||
] { } make ;
|
||||
|
||||
: return-size ( ctype -- n )
|
||||
#! Amount of space we reserve for a return value.
|
||||
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
||||
|
||||
: alien-stack-frame ( params -- n )
|
||||
alien-parameters parameter-sizes drop ;
|
||||
|
||||
: alien-invoke-frame ( params -- n )
|
||||
#! One cell is temporary storage, temp@
|
||||
dup return>> return-size
|
||||
swap alien-stack-frame +
|
||||
cell + ;
|
||||
|
||||
: set-stack-frame ( n -- )
|
||||
dup [ frame-required ] when* \ stack-frame set ;
|
||||
|
||||
: with-stack-frame ( n quot -- )
|
||||
swap set-stack-frame
|
||||
call
|
||||
f set-stack-frame ; inline
|
||||
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
M: int-regs reg-size drop cell ;
|
||||
|
||||
M: single-float-regs reg-size drop 4 ;
|
||||
|
||||
M: double-float-regs reg-size drop 8 ;
|
||||
|
||||
GENERIC: reg-class-variable ( register-class -- symbol )
|
||||
|
||||
M: reg-class reg-class-variable ;
|
||||
|
||||
M: float-regs reg-class-variable drop float-regs ;
|
||||
|
||||
GENERIC: inc-reg-class ( register-class -- )
|
||||
|
||||
M: reg-class inc-reg-class
|
||||
dup reg-class-variable inc
|
||||
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
|
||||
|
||||
M: float-regs inc-reg-class
|
||||
dup call-next-method
|
||||
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
|
||||
|
||||
: reg-class-full? ( class -- ? )
|
||||
[ reg-class-variable get ] [ param-regs length ] bi >= ;
|
||||
|
||||
: spill-param ( reg-class -- n reg-class )
|
||||
stack-params get
|
||||
>r reg-size stack-params +@ r>
|
||||
stack-params ;
|
||||
|
||||
: fastcall-param ( reg-class -- n reg-class )
|
||||
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
|
||||
|
||||
: alloc-parameter ( parameter -- reg reg-class )
|
||||
c-type-reg-class dup reg-class-full?
|
||||
[ spill-param ] [ fastcall-param ] if
|
||||
[ param-reg ] keep ;
|
||||
|
||||
: (flatten-int-type) ( size -- )
|
||||
cell /i "void*" c-type <repetition> % ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- )
|
||||
|
||||
M: object flatten-value-type , ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
>r [ parameter-sizes nip ] keep r> 2each ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
|
||||
|
||||
: reset-freg-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
||||
: with-param-regs ( quot -- )
|
||||
#! In quot you can call alloc-parameter
|
||||
[ reset-freg-counts call ] with-scope ; inline
|
||||
|
||||
: move-parameters ( node word -- )
|
||||
#! Moves values from C stack to registers (if word is
|
||||
#! %load-param-reg) and registers to C stack (if word is
|
||||
#! %save-param-reg).
|
||||
>r
|
||||
alien-parameters
|
||||
flatten-value-types
|
||||
r> [ >r alloc-parameter r> execute ] curry each-parameter ;
|
||||
inline
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> [
|
||||
%prepare-unbox >r over + r> unbox-parameter
|
||||
] reverse-each-parameter drop ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
#! parameters. If the C function is returning a structure,
|
||||
#! the first parameter is an implicit target area pointer,
|
||||
#! so we need to use a different offset.
|
||||
return>> dup large-struct?
|
||||
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
|
||||
|
||||
: objects>registers ( params -- )
|
||||
#! Generate code for unboxing a list of C types, then
|
||||
#! generate code for moving these parameters to register on
|
||||
#! architectures where parameters are passed in registers.
|
||||
[
|
||||
[ prepare-box-struct ] keep
|
||||
[ unbox-parameters ] keep
|
||||
\ %load-param-reg move-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return ] if-void ;
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd [ dlsym ] curry contains?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
] if ;
|
||||
|
||||
: stdcall-mangle ( symbol node -- symbol )
|
||||
"@"
|
||||
swap parameters>> parameter-sizes drop
|
||||
number>string 3append ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
|
||||
M: #alien-invoke generate-node
|
||||
params>>
|
||||
dup alien-invoke-frame [
|
||||
end-basic-block
|
||||
%prepare-alien-invoke
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
dup alien-invoke-dlsym %alien-invoke
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
|
||||
! #alien-indirect
|
||||
M: #alien-indirect generate-node
|
||||
params>>
|
||||
dup alien-invoke-frame [
|
||||
! Flush registers
|
||||
end-basic-block
|
||||
! Save registers for GC
|
||||
%prepare-alien-invoke
|
||||
! Save alien at top of stack to temporary storage
|
||||
%prepare-alien-indirect
|
||||
dup objects>registers
|
||||
%prepare-var-args
|
||||
! Call alien in temporary storage
|
||||
%alien-indirect
|
||||
dup %cleanup
|
||||
box-return*
|
||||
iterate-next
|
||||
] with-stack-frame ;
|
||||
|
||||
! #alien-callback
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters [ box-parameter ] each-parameter ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
[
|
||||
dup \ %save-param-reg move-parameters
|
||||
"nest_stacks" f %alien-invoke
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
TUPLE: callback-context ;
|
||||
|
||||
: current-callback 2 getenv ;
|
||||
|
||||
: wait-to-return ( token -- )
|
||||
dup current-callback eq? [
|
||||
drop
|
||||
] [
|
||||
yield wait-to-return
|
||||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
wait-to-return ; inline
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: callback-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: wrap-callback-quot ( params -- quot )
|
||||
[
|
||||
[ callback-prep-quot ]
|
||||
[ quot>> ]
|
||||
[ callback-return-quot ] tri 3append ,
|
||||
[ callback-context new do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||
|
||||
: callback-unwind ( params -- n )
|
||||
{
|
||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
: %callback-return ( params -- )
|
||||
#! All the extra book-keeping for %unwind is only for x86.
|
||||
#! On other platforms its an alias for %return.
|
||||
dup alien-return
|
||||
[ %unnest-stacks ] [ %callback-value ] if-void
|
||||
callback-unwind %unwind ;
|
||||
|
||||
: generate-callback ( params -- )
|
||||
dup xt>> dup [
|
||||
init-templates
|
||||
%prologue-later
|
||||
dup alien-stack-frame [
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ %callback-return ]
|
||||
tri
|
||||
] with-stack-frame
|
||||
] with-generator ;
|
||||
|
||||
M: #alien-callback generate-node
|
||||
end-basic-block
|
||||
params>> generate-callback iterate-next ;
|
||||
|
|
|
|||
|
|
@ -179,10 +179,10 @@ SYMBOL: +primitive+
|
|||
{ [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
|
||||
{ [ dup +special+ word-prop ] [ infer-special ] }
|
||||
{ [ dup +primitive+ word-prop ] [ infer-primitive ] }
|
||||
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
|
||||
{ [ dup +transform-quot+ word-prop ] [ apply-transform ] }
|
||||
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
||||
{ [ dup "macro" word-prop ] [ apply-macro ] }
|
||||
{ [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
|
||||
{ [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
|
||||
{ [ dup recursive-label ] [ call-recursive-word ] }
|
||||
[ dup infer-word apply-word/effect ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -23,10 +23,11 @@ SYMBOL: +transform-n+
|
|||
inline
|
||||
|
||||
: (apply-transform) ( word quot n -- )
|
||||
consume-d dup [ known literal? ] all? [
|
||||
dup ensure-d [ known literal? ] all? [
|
||||
dup empty? [
|
||||
drop recursive-state get 1array
|
||||
] [
|
||||
consume-d
|
||||
[ #drop, ]
|
||||
[ [ literal value>> ] map ]
|
||||
[ first literal recursion>> ] tri prefix
|
||||
|
|
@ -123,7 +124,6 @@ SYMBOL: +transform-n+
|
|||
|
||||
: bit-member-quot ( seq -- newquot )
|
||||
[
|
||||
[ drop ] % ! drop the sequence itself; we don't use it at run time
|
||||
bit-member-seq ,
|
||||
[
|
||||
{
|
||||
|
|
@ -140,7 +140,7 @@ SYMBOL: +transform-n+
|
|||
bit-member-quot
|
||||
] [
|
||||
[ literalize [ t ] ] { } map>assoc
|
||||
[ drop f ] suffix [ nip case ] curry
|
||||
[ drop f ] suffix [ case ] curry
|
||||
] if ;
|
||||
|
||||
\ member? [
|
||||
|
|
|
|||
Loading…
Reference in New Issue