From 029719f757fdceb633edbf2ba61962db73015a98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 May 2010 00:44:21 -0400 Subject: [PATCH 1/2] functors: fix unit test --- basis/functors/functors-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index c756d1b83d..f1e4040167 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -159,7 +159,7 @@ T-class DEFINES-CLASS ${T} WHERE STRUCT: T-class - { NAME c:int } + { NAME c:longlong } { x { TYPE 4 } } { y { c:short N } } { z TYPE initial: 5 } @@ -178,32 +178,32 @@ STRUCT: T-class { offset 0 } { class integer } { initial 0 } - { type c:int } + { type c:longlong } } T{ struct-slot-spec { name "x" } - { offset 4 } + { offset 8 } { class object } { initial f } { type { c:char 4 } } } T{ struct-slot-spec { name "y" } - { offset 8 } + { offset 12 } { class object } { initial f } { type { c:short 2 } } } T{ struct-slot-spec { name "z" } - { offset 12 } + { offset 16 } { class fixnum } { initial 5 } { type c:char } } T{ struct-slot-spec { name "float" } - { offset 16 } + { offset 20 } { class object } { initial f } { type { c:float 2 } } From e763c74096d9e42c05b4f0f454a7201aed32b1b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 May 2010 01:13:45 -0400 Subject: [PATCH 2/2] More FFI cleanups --- basis/alien/arrays/arrays.factor | 14 ++--- basis/alien/c-types/c-types.factor | 57 +++++++++++---------- basis/classes/struct/struct.factor | 12 +++-- basis/compiler/alien/alien.factor | 13 ----- basis/compiler/cfg/builder/builder.factor | 2 +- basis/compiler/codegen/alien/alien.factor | 62 +++++++---------------- basis/cpu/x86/32/32.factor | 19 +++---- basis/cpu/x86/64/64.factor | 14 ++--- basis/cpu/x86/64/unix/unix.factor | 17 +++---- vm/booleans.cpp | 10 ---- vm/booleans.hpp | 3 -- 11 files changed, 82 insertions(+), 141 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index e112a38d25..dc9d3e0d05 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -22,8 +22,6 @@ M: array c-type-align first c-type-align ; M: array c-type-align-first first c-type-align-first ; -M: array c-type-stack-align? drop f ; - M: array unbox-parameter drop void* unbox-parameter ; M: array unbox-return drop void* unbox-return ; @@ -34,6 +32,8 @@ M: array box-return drop void* box-return ; M: array stack-size drop void* stack-size ; +M: array flatten-c-type drop { int-rep } ; + PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; @@ -52,9 +52,6 @@ M: string-type c-type-align M: string-type c-type-align-first drop void* c-type-align-first ; -M: string-type c-type-stack-align? - drop void* c-type-stack-align? ; - M: string-type unbox-parameter drop void* unbox-parameter ; @@ -73,11 +70,8 @@ M: string-type stack-size M: string-type c-type-rep drop int-rep ; -M: string-type c-type-boxer - drop void* c-type-boxer ; - -M: string-type c-type-unboxer - drop void* c-type-unboxer ; +M: string-type flatten-c-type + drop { int-rep } ; M: string-type c-type-boxer-quot second dup binary = diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 6ded9f4e0d..98b15b7af8 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs delegate kernel kernel.private math math.order math.parser namespaces make parser sequences strings @@ -17,7 +17,8 @@ SYMBOLS: long ulong longlong ulonglong float double - void* bool ; + void* bool + (stack-value) ; SINGLETON: void @@ -38,8 +39,7 @@ TUPLE: abstract-c-type TUPLE: c-type < abstract-c-type boxer unboxer -{ rep initial: int-rep } -stack-align? ; +{ rep initial: int-rep } ; : ( -- c-type ) \ c-type new ; inline @@ -83,18 +83,10 @@ GENERIC: c-type-boxed-class ( name -- class ) M: abstract-c-type c-type-boxed-class boxed-class>> ; -GENERIC: c-type-boxer ( name -- boxer ) - -M: c-type c-type-boxer boxer>> ; - GENERIC: c-type-boxer-quot ( name -- quot ) M: abstract-c-type c-type-boxer-quot boxer-quot>> ; -GENERIC: c-type-unboxer ( name -- boxer ) - -M: c-type c-type-unboxer unboxer>> ; - GENERIC: c-type-unboxer-quot ( name -- quot ) M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ; @@ -119,17 +111,11 @@ GENERIC: c-type-align-first ( name -- n ) M: abstract-c-type c-type-align-first align-first>> ; -GENERIC: c-type-stack-align? ( name -- ? ) - -M: c-type c-type-stack-align? stack-align?>> ; - : c-type-box ( n c-type -- ) - [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi - %box ; + [ rep>> ] [ boxer>> ] bi %box ; : c-type-unbox ( n c-type -- ) - [ c-type-rep ] [ c-type-unboxer [ "No unboxer" throw ] unless* ] bi - %unbox ; + [ rep>> ] [ unboxer>> ] bi %unbox ; GENERIC: box-parameter ( n c-type -- ) @@ -157,9 +143,16 @@ GENERIC: stack-size ( name -- size ) M: c-type stack-size size>> cell align ; -: >c-bool ( ? -- int ) 1 0 ? ; inline +: (flatten-c-type) ( type rep -- seq ) + [ stack-size cell /i ] dip ; inline -: c-bool> ( int -- ? ) 0 = not ; inline +GENERIC: flatten-c-type ( type -- reps ) + +M: c-type flatten-c-type rep>> 1array ; +M: c-type-name flatten-c-type c-type flatten-c-type ; + +: flatten-c-types ( types -- reps ) + [ flatten-c-type ] map concat ; MIXIN: value-type @@ -179,22 +172,20 @@ MIXIN: value-type PROTOCOL: c-type-protocol c-type-class c-type-boxed-class - c-type-boxer c-type-boxer-quot - c-type-unboxer c-type-unboxer-quot c-type-rep c-type-getter c-type-setter c-type-align c-type-align-first - c-type-stack-align? box-parameter box-return unbox-parameter unbox-return heap-size - stack-size ; + stack-size + flatten-c-type ; CONSULT: c-type-protocol c-type-name c-type ; @@ -214,17 +205,20 @@ TUPLE: long-long-type < c-type ; long-long-type new ; M: long-long-type unbox-parameter ( n c-type -- ) - c-type-unboxer %unbox-long-long ; + 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 -- ) - c-type-boxer %box-long-long ; + 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) ; + : define-deref ( c-type -- ) [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi (( c-ptr -- value )) define-inline ; @@ -259,6 +253,10 @@ CONSTANT: primitive-types : (pointer-c-type) ( void* type -- void*' ) [ clone ] dip c-type-boxer-quot '[ _ [ f ] if* ] >>boxer-quot ; +: >c-bool ( ? -- int ) 1 0 ? ; inline + +: c-bool> ( int -- ? ) 0 = not ; inline + >boxed-class \ bool define-primitive-type + \ void* c-type clone stack-params >>rep + \ (stack-value) define-primitive-type + ] with-compilation-unit M: char-16-rep rep-component-type drop char ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 60ef793063..48b2aa5f32 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -9,7 +9,7 @@ locals macros make math math.order parser quotations sequences slots slots.private specialized-arrays vectors words summary namespaces assocs vocabs.parser math.functions classes.struct.bit-accessors bit-arrays -stack-checker.dependencies ; +stack-checker.dependencies system layouts ; QUALIFIED: math IN: classes.struct @@ -166,8 +166,6 @@ INSTANCE: struct-c-type value-type M: struct-c-type c-type ; -M: struct-c-type c-type-stack-align? drop f ; - : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline @@ -187,7 +185,13 @@ M: struct-c-type box-return [ %box-small-struct ] [ %box-large-struct ] if-small-struct ; M: struct-c-type stack-size - [ heap-size ] [ stack-size ] if-value-struct ; + [ heap-size cell align ] [ stack-size ] if-value-struct ; + +HOOK: flatten-struct-type cpu ( type -- reps ) + +M: object flatten-struct-type int-rep (flatten-c-type) ; + +M: struct-c-type flatten-c-type flatten-struct-type ; M: struct-c-type c-struct? drop t ; diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 63df85be05..58c5aaf734 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -13,16 +13,3 @@ IN: compiler.alien : alien-return ( params -- type ) 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 ) - [ c-type-stack-align align dup ] [ drop ] 2bi - ; - -: parameter-offsets ( types -- total offsets ) - [ - 0 [ - [ parameter-align drop dup , ] keep stack-size + - ] reduce cell align - ] { } make ; diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 07f3c0aae4..c0ba1144a5 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -218,7 +218,7 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; stack-frame new swap [ return>> return-size >>return ] - [ alien-parameters parameter-offsets drop >>params ] bi + [ alien-parameters [ stack-size ] map-sum >>params ] bi t >>calls-vm? ; : alien-node-height ( params -- ) diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor index 5123b1c62c..3af220376c 100644 --- a/basis/compiler/codegen/alien/alien.factor +++ b/basis/compiler/codegen/alien/alien.factor @@ -6,7 +6,8 @@ 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 ; +math.order math.parser namespaces quotations sequences strings +system ; FROM: compiler.errors => no-such-symbol ; IN: compiler.codegen.alien @@ -46,44 +47,11 @@ M: reg-class reg-class-full? : alloc-fastcall-param ( rep -- n reg-class rep ) [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; -:: alloc-parameter ( parameter abi -- reg rep ) - parameter c-type-rep dup reg-class-of abi reg-class-full? +:: 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 ; -SYMBOL: (stack-value) -<< void* c-type clone \ (stack-value) define-primitive-type -stack-params \ (stack-value) c-type (>>rep) >> - -: ((flatten-type)) ( type to-type -- seq ) - [ stack-size cell align cell /i ] dip c-type ; inline - -: (flatten-int-type) ( type -- seq ) - void* ((flatten-type)) ; -: (flatten-stack-type) ( type -- seq ) - (stack-value) ((flatten-type)) ; - -GENERIC: flatten-value-type ( type -- types ) - -M: object flatten-value-type 1array ; -M: struct-c-type flatten-value-type (flatten-int-type) ; -M: long-long-type flatten-value-type (flatten-int-type) ; -M: c-type-name flatten-value-type c-type flatten-value-type ; - -: flatten-value-types ( params -- params ) - #! Convert value type structs to consecutive void*s. - [ - 0 [ - c-type - [ parameter-align cell /i void* c-type % ] keep - [ stack-size cell align + ] keep - flatten-value-type % - ] reduce drop - ] { } make ; - -: each-parameter ( parameters quot -- ) - [ [ parameter-offsets nip ] keep ] dip 2each ; inline - : reset-fastcall-counts ( -- ) { int-regs float-regs stack-params } [ 0 swap set ] each ; @@ -91,19 +59,27 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; #! In quot you can call alloc-parameter [ reset-fastcall-counts call ] with-scope ; inline -: move-parameters ( node word -- ) +:: 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). - [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ] - [ '[ _ alloc-parameter _ execute ] ] - bi* each-parameter ; inline + 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 nip ] keep ] dip 2reverse-each ; inline + [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline : prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets nip ] [ ] [ length iota ] tri ; + [ parameter-offsets ] [ ] [ length iota ] tri ; : unbox-parameters ( offset node -- ) parameters>> swap @@ -147,7 +123,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; ] if ; : decorated-symbol ( params -- symbols ) - [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi + [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi { [ drop ] [ "@" glue ] diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index cd0fa4faff..6d81d50691 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -5,11 +5,10 @@ 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.cfg.intrinsics compiler.cfg.stack-frame -cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture vm ; +compiler.codegen.fixup compiler.cfg.instructions +compiler.cfg.builder compiler.cfg.intrinsics +compiler.cfg.stack-frame cpu.x86.assembler +cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ; FROM: layouts => cell ; IN: cpu.x86.32 @@ -326,7 +325,7 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) : stack-arg-size ( params -- n ) dup abi>> '[ - alien-parameters flatten-value-types + alien-parameters flatten-c-types [ _ alloc-parameter 2drop ] each stack-params get ] with-param-regs ; @@ -357,11 +356,9 @@ M: x86.32 dummy-int-params? f ; M: x86.32 dummy-fp-params? f ; ! Dreadful -M: object flatten-value-type (flatten-stack-type) ; -M: struct-c-type flatten-value-type (flatten-stack-type) ; -M: long-long-type flatten-value-type (flatten-stack-type) ; -M: c-type flatten-value-type - dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ; +M: struct-c-type flatten-c-type stack-params (flatten-c-type) ; +M: long-long-type flatten-c-type stack-params (flatten-c-type) ; +M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type)) ; M: x86.32 struct-return-pointer-type os linux? void* (stack-value) ? ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 93f7c6d22f..928daa741e 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -3,7 +3,7 @@ USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.libraries slots splitting assocs combinators locals compiler.constants -compiler.codegen compiler.codegen.alien compiler.codegen.fixup +classes.struct compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 @@ -132,9 +132,9 @@ M:: x86.64 %unbox ( n rep func -- ) ! this is the end of alien-callback n [ n rep reg-class-of return-reg rep %save-param-reg ] when ; -: %unbox-struct-field ( c-type i -- ) +: %unbox-struct-field ( rep i -- ) ! Alien must be in param-reg-0. - R11 swap cells [+] swap rep>> reg-class-of { + R11 swap cells [+] swap reg-class-of { { int-regs [ int-regs get pop swap MOV ] } { float-regs [ float-regs get pop swap MOVSD ] } } case ; @@ -147,7 +147,7 @@ M: x86.64 %unbox-small-struct ( c-type -- ) ! clobber it. R11 RAX MOV [ - flatten-value-type [ %unbox-struct-field ] each-index + flatten-struct-type [ %unbox-struct-field ] each-index ] with-return-regs ; M:: x86.64 %unbox-large-struct ( n c-type -- ) @@ -179,8 +179,8 @@ M:: x86.64 %box ( n rep func -- ) : box-struct-field@ ( i -- operand ) 1 + cells param@ ; -: %box-struct-field ( c-type i -- ) - box-struct-field@ swap c-type-rep reg-class-of { +: %box-struct-field ( rep i -- ) + box-struct-field@ swap reg-class-of { { int-regs [ int-regs get pop MOV ] } { float-regs [ float-regs get pop MOVSD ] } } case ; @@ -188,7 +188,7 @@ M:: x86.64 %box ( n rep func -- ) M: x86.64 %box-small-struct ( c-type -- ) #! Box a <= 16-byte struct. [ - [ flatten-value-type [ %box-struct-field ] each-index ] + [ flatten-struct-type [ %box-struct-field ] each-index ] [ param-reg-2 swap heap-size MOV ] bi param-reg-0 0 box-struct-field@ MOV param-reg-1 1 box-struct-field@ MOV diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index fd696b7fda..ce98b53fef 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -27,21 +27,16 @@ M: x86.64 reserved-stack-space 0 ; : flatten-small-struct ( c-type -- seq ) struct-types&offset split-struct [ [ c-type c-type-rep reg-class-of ] map - int-regs swap member? void* double ? c-type + int-regs swap member? int-rep double-rep ? ] map ; : flatten-large-struct ( c-type -- seq ) - (flatten-stack-type) ; + stack-params (flatten-c-type) ; -: flatten-struct ( c-type -- seq ) - dup heap-size 16 > [ - flatten-large-struct - ] [ - flatten-small-struct - ] if ; - -M: struct-c-type flatten-value-type ( type -- seq ) - flatten-struct ; +M: x86.64 flatten-struct-type ( c-type -- seq ) + dup heap-size 16 > + [ flatten-large-struct ] + [ flatten-small-struct ] if ; M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size 2 cells <= ; diff --git a/vm/booleans.cpp b/vm/booleans.cpp index dedb385f3d..86b2a7dc6c 100644 --- a/vm/booleans.cpp +++ b/vm/booleans.cpp @@ -3,14 +3,4 @@ namespace factor { -VM_C_API bool to_boolean(cell value, factor_vm *parent) -{ - return to_boolean(value); -} - -VM_C_API cell from_boolean(bool value, factor_vm *parent) -{ - return parent->tag_boolean(value); -} - } diff --git a/vm/booleans.hpp b/vm/booleans.hpp index a11103c5c6..55fea6c193 100644 --- a/vm/booleans.hpp +++ b/vm/booleans.hpp @@ -1,9 +1,6 @@ namespace factor { -VM_C_API bool to_boolean(cell value, factor_vm *vm); -VM_C_API cell from_boolean(bool value, factor_vm *vm); - /* Cannot allocate */ inline static bool to_boolean(cell value) {