Debugging front-end, updating FFI codegen

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
+kernel.private layouts math math.parser namespaces prettyprint
-sequences system threads words vectors sets dequeues cursors
+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 ;

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 ;

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? [