From 762007b28e0e9d47d4ce8cc59eb07c9898d0b92e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Aug 2008 03:18:15 -0500 Subject: [PATCH] Debugging front-end, updating FFI codegen --- .../compiler/generator/generator.factor | 321 +++++++++++++++++- .../known-words/known-words.factor | 4 +- .../transforms/transforms.factor | 6 +- 3 files changed, 323 insertions(+), 8 deletions(-) diff --git a/unfinished/compiler/generator/generator.factor b/unfinished/compiler/generator/generator.factor index 19e60ae19c..a4a7815d70 100755 --- a/unfinished/compiler/generator/generator.factor +++ b/unfinished/compiler/generator/generator.factor @@ -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 % ; + +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 ; diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor index eb9a9dbdf7..a0c91f679b 100755 --- a/unfinished/stack-checker/known-words/known-words.factor +++ b/unfinished/stack-checker/known-words/known-words.factor @@ -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 ; diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor index d9e889f188..f22960dd39 100755 --- a/unfinished/stack-checker/transforms/transforms.factor +++ b/unfinished/stack-checker/transforms/transforms.factor @@ -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? [