From 9e2fab61ef4bd0144f66d335d6ca546131e676f9 Mon Sep 17 00:00:00 2001 From: Dmitry Shubin Date: Thu, 13 May 2010 20:20:16 +0400 Subject: [PATCH 01/20] FUEL: syntax highlighting for DESTRUCTOR: and C-GLOBAL: --- misc/fuel/fuel-font-lock.el | 3 +++ misc/fuel/fuel-syntax.el | 15 +++++++++------ 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 8d3990fcd8..b9bd175dc5 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -111,6 +111,9 @@ (,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-type-name) (3 'factor-font-lock-invalid-syntax nil t)) + (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name) + (2 'factor-font-lock-word) + (3 'factor-font-lock-invalid-syntax nil t)) (,fuel-syntax--rename-regex (1 'factor-font-lock-word) (2 'factor-font-lock-vocabulary-name) (3 'factor-font-lock-word) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 80010235b1..b2a8a57345 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -47,9 +47,9 @@ '(":" "::" ";" "&:" "<<" ">" "ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:" "B" "BEFORE:" "BIN:" - "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method" - "DEFER:" - "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:" + "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method" + "DEFER:" "DESTRUCTOR:" + "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:" "f" "FORGET:" "FROM:" "FUNCTION:" "GAME:" "GENERIC#" "GENERIC:" "GLSL-SHADER:" "GLSL-PROGRAM:" @@ -197,10 +197,10 @@ (defconst fuel-syntax--single-liner-regex (regexp-opt '("ABOUT:" "ALIAS:" - "CONSTANT:" "C:" "C-TYPE:" - "DEFER:" + "CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:" + "DEFER:" "DESTRUCTOR:" "FORGET:" - "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" + "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" "HEX:" "HOOK:" "IN:" "INSTANCE:" "LIBRARY:" @@ -242,6 +242,9 @@ (defconst fuel-syntax--typedef-regex "\\_ +\\(\\w+\\)\\( .*\\)?$") From d24ffe8346e28fe21695ca8c74408079dd325a0a Mon Sep 17 00:00:00 2001 From: Dmitry Shubin Date: Thu, 13 May 2010 22:50:26 +0400 Subject: [PATCH 02/20] FUEL: improve syntax highlighting: C-TYPE:, FUNCTION-ALIAS: and more --- misc/fuel/fuel-font-lock.el | 5 +++++ misc/fuel/fuel-syntax.el | 14 ++++++++++---- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index b9bd175dc5..8ccf50d0e0 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -101,6 +101,9 @@ (,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word) (,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word)) + (,fuel-syntax--alien-function-alias-regex (1 'factor-font-lock-word) + (2 'factor-font-lock-type-name) + (3 'factor-font-lock-word)) (,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word)) (,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name) @@ -114,6 +117,8 @@ (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word) (3 'factor-font-lock-invalid-syntax nil t)) + (,fuel-syntax--c-type-regex (1 'factor-font-lock-type-name) + (2 'factor-font-lock-invalid-syntax nil t)) (,fuel-syntax--rename-regex (1 'factor-font-lock-word) (2 'factor-font-lock-vocabulary-name) (3 'factor-font-lock-word) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index b2a8a57345..0d77d9cc13 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -50,7 +50,7 @@ "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method" "DEFER:" "DESTRUCTOR:" "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:" - "f" "FORGET:" "FROM:" "FUNCTION:" + "f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:" "GAME:" "GENERIC#" "GENERIC:" "GLSL-SHADER:" "GLSL-PROGRAM:" "HELP:" "HEX:" "HOOK:" @@ -158,15 +158,18 @@ (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") (defconst fuel-syntax--alien-function-regex - "\\_ +\\(\\w+\\)\\( .*\\)?$") From 379f34a82155a1ddd3157a61197b0846637fd698 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 9 Jun 2010 14:45:25 +0200 Subject: [PATCH 03/20] added new BSON types --- extra/bson/constants/constants.factor | 61 ++++++++++++++++----------- extra/bson/reader/reader.factor | 18 ++++++-- 2 files changed, 51 insertions(+), 28 deletions(-) diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor index 2d126857c3..e4bf14432a 100644 --- a/extra/bson/constants/constants.factor +++ b/extra/bson/constants/constants.factor @@ -19,6 +19,16 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: dbref ref id db ; +TUPLE: mongo-timestamp incr seconds ; + +: ( incr seconds -- mongo-timestamp ) + mongo-timestamp boa ; + +TUPLE: mongo-scoped-code code object ; + +: ( code object -- mongo-scoped-code ) + mongo-scoped-code boa ; + CONSTRUCTOR: dbref ( ref id -- dbref ) ; : dbref>assoc ( dbref -- assoc ) @@ -47,30 +57,31 @@ TUPLE: mdbregexp { regexp string } { options string } ; CONSTANT: MDB_OID_FIELD "_id" CONSTANT: MDB_META_FIELD "_mfd" -CONSTANT: T_EOO 0 -CONSTANT: T_Double 1 -CONSTANT: T_Integer 16 -CONSTANT: T_Boolean 8 -CONSTANT: T_String 2 -CONSTANT: T_Object 3 -CONSTANT: T_Array 4 -CONSTANT: T_Binary 5 -CONSTANT: T_Undefined 6 -CONSTANT: T_OID 7 -CONSTANT: T_Date 9 -CONSTANT: T_NULL 10 -CONSTANT: T_Regexp 11 -CONSTANT: T_DBRef 12 -CONSTANT: T_Code 13 -CONSTANT: T_ScopedCode 17 -CONSTANT: T_Symbol 14 -CONSTANT: T_JSTypeMax 16 -CONSTANT: T_MaxKey 127 - -CONSTANT: T_Binary_Function 1 -CONSTANT: T_Binary_Bytes 2 -CONSTANT: T_Binary_UUID 3 -CONSTANT: T_Binary_MD5 5 -CONSTANT: T_Binary_Custom 128 +CONSTANT: T_EOO 0 +CONSTANT: T_Double HEX: 1 +CONSTANT: T_String HEX: 2 +CONSTANT: T_Object HEX: 3 +CONSTANT: T_Array HEX: 4 +CONSTANT: T_Binary HEX: 5 +CONSTANT: T_Undefined HEX: 6 +CONSTANT: T_OID HEX: 7 +CONSTANT: T_Boolean HEX: 8 +CONSTANT: T_Date HEX: 9 +CONSTANT: T_NULL HEX: A +CONSTANT: T_Regexp HEX: B +CONSTANT: T_DBRef HEX: C +CONSTANT: T_Code HEX: D +CONSTANT: T_Symbol HEX: E +CONSTANT: T_ScopedCode HEX: F +CONSTANT: T_Integer HEX: 10 +CONSTANT: T_Timestamp HEX: 11 +CONSTANT: T_Integer64 HEX: 12 +CONSTANT: T_MinKey HEX: FF +CONSTANT: T_MaxKey HEX: 7F +CONSTANT: T_Binary_Function HEX: 1 +CONSTANT: T_Binary_Bytes HEX: 2 +CONSTANT: T_Binary_UUID HEX: 3 +CONSTANT: T_Binary_MD5 HEX: 5 +CONSTANT: T_Binary_Custom HEX: 80 diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index e0cf0bc4f4..9b04b333e8 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -10,6 +10,8 @@ FROM: typed => TYPED: ; IN: bson.reader +DEFER: stream>assoc + string ; inline +TYPED: read-timestamp ( -- timestamp ) + 8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi ; + TYPED: push-element ( type: integer name: string state: state -- ) [ element boa ] dip elements>> push ; inline @@ -91,6 +96,7 @@ TYPED: element-data-read ( type: integer -- object ) { T_OID [ bson-oid-read ] } { T_String [ read-int32 read-sized-string ] } { T_Integer [ read-int32 ] } + { T_Integer64 [ read-longlong ] } { T_Binary [ bson-binary-read ] } { T_Object [ bson-object-data-read ] } { T_Array [ bson-object-data-read ] } @@ -98,6 +104,9 @@ TYPED: element-data-read ( type: integer -- object ) { T_Boolean [ read-byte 1 = ] } { T_Date [ read-longlong millis>timestamp ] } { T_Regexp [ bson-regexp-read ] } + { T_Timestamp [ read-timestamp ] } + { T_Code [ read-int32 read-sized-string ] } + { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc ] } { T_NULL [ f ] } } case ; inline @@ -135,9 +144,12 @@ TYPED: (prepare-result) ( scope: vector element: element -- result ) TYPED: (prepare-object) ( type: integer -- object ) [ element-data-read ] [ end-element ] bi ; inline -:: (read-object) ( type name state -- ) - state peek-scope :> scope - type (prepare-object) name scope set-at ; inline +! :: (read-object) ( type name state -- ) +! state peek-scope :> scope +! type (prepare-object) name scope set-at ; inline + +: (read-object) ( type name state -- ) + peek-scope [ (prepare-object) ] 2dip set-at ; inline TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean ) read-cstring get-state From 5ca5210ed67c63fc160fe0dcb52642ad4c92d153 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 10 Jun 2010 19:57:19 +0200 Subject: [PATCH 04/20] simplified bson.reader and made it faster --- extra/bson/reader/reader.factor | 148 +++++++++----------------------- 1 file changed, 42 insertions(+), 106 deletions(-) diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 9b04b333e8..852f46f951 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -10,70 +10,46 @@ FROM: typed => TYPED: ; IN: bson.reader +SYMBOL: state + DEFER: stream>assoc ( exemplar -- state ) - [ state new ] dip - { - [ clone >>exemplar ] - [ clone >>result ] - [ V{ } clone [ push ] keep >>scope ] - } cleave - (prepare-elements) >>elements ; - -TYPED: get-state ( -- state: state ) - state get ; inline - -TYPED: read-int32 ( -- int32: integer ) +: read-int32 ( -- int32 ) 4 read signed-le> ; inline -TYPED: read-longlong ( -- longlong: integer ) +: read-longlong ( -- longlong ) 8 read signed-le> ; inline -TYPED: read-double ( -- double: float ) +: read-double ( -- double ) 8 read le> bits>double ; inline -TYPED: read-byte-raw ( -- byte-raw: byte-array ) +: read-byte-raw ( -- byte-raw ) 1 read ; inline -TYPED: read-byte ( -- byte: integer ) +: read-byte ( -- byte ) read-byte-raw first ; inline -TYPED: read-cstring ( -- string: string ) +: read-cstring ( -- string ) "\0" read-until drop >string ; inline -TYPED: read-sized-string ( length: integer -- string: string ) +: read-sized-string ( length -- string ) read 1 head-slice* >string ; inline -TYPED: read-timestamp ( -- timestamp ) +: read-timestamp ( -- timestamp ) 8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi ; -TYPED: push-element ( type: integer name: string state: state -- ) - [ element boa ] dip elements>> push ; inline +: object-result ( quot -- object ) + [ + state get clone + [ clear-assoc ] [ ] [ ] tri state + ] dip with-variable ; inline -TYPED: pop-element ( state: state -- element: element ) - elements>> pop ; inline - -TYPED: peek-scope ( state: state -- ht ) - scope>> last ; inline - -: bson-object-data-read ( -- object ) - read-int32 drop get-state - [ exemplar>> clone dup ] [ scope>> ] bi push ; inline +: bson-object-data-read ( -- ) + read-int32 drop read-elements ; inline recursive : bson-binary-read ( -- binary ) read-int32 read-byte @@ -91,75 +67,35 @@ TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp ) TYPED: bson-oid-read ( -- oid: oid ) read-longlong read-int32 oid boa ; inline -TYPED: element-data-read ( type: integer -- object ) - { - { T_OID [ bson-oid-read ] } - { T_String [ read-int32 read-sized-string ] } - { T_Integer [ read-int32 ] } - { T_Integer64 [ read-longlong ] } - { T_Binary [ bson-binary-read ] } - { T_Object [ bson-object-data-read ] } - { T_Array [ bson-object-data-read ] } - { T_Double [ read-double ] } - { T_Boolean [ read-byte 1 = ] } - { T_Date [ read-longlong millis>timestamp ] } - { T_Regexp [ bson-regexp-read ] } - { T_Timestamp [ read-timestamp ] } - { T_Code [ read-int32 read-sized-string ] } - { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc ] } - { T_NULL [ f ] } - } case ; inline - -TYPED: bson-array? ( type: integer -- ?: boolean ) - T_Array = ; inline - -TYPED: bson-object? ( type: integer -- ?: boolean ) - T_Object = ; inline - : check-object ( assoc -- object ) dup dbref-assoc? [ assoc>dbref ] when ; inline -TYPED: fix-result ( assoc type: integer -- result ) +TYPED: element-data-read ( type: integer -- object ) { - { T_Array [ values ] } - { T_Object [ check-object ] } - } case ; inline + { T_OID [ bson-oid-read ] } + { T_String [ read-int32 read-sized-string ] } + { T_Integer [ read-int32 ] } + { T_Integer64 [ read-longlong ] } + { T_Binary [ bson-binary-read ] } + { T_Object [ [ bson-object-data-read ] object-result check-object ] } + { T_Array [ [ bson-object-data-read ] object-result values ] } + { T_Double [ read-double ] } + { T_Boolean [ read-byte 1 = ] } + { T_Date [ read-longlong millis>timestamp ] } + { T_Regexp [ bson-regexp-read ] } + { T_Timestamp [ read-timestamp ] } + { T_Code [ read-int32 read-sized-string ] } + { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc ] } + { T_NULL [ f ] } + } case ; inline recursive -TYPED: end-element ( type: integer -- ) - { [ bson-object? ] [ bson-array? ] } 1|| - [ get-state pop-element drop ] unless ; inline - -TYPED: (>state<) ( -- state: state scope: vector element: element ) - get-state [ ] [ scope>> ] [ pop-element ] tri ; inline - -TYPED: (prepare-result) ( scope: vector element: element -- result ) - [ pop ] [ type>> ] bi* fix-result ; inline - -: bson-eoo-element-read ( -- cont?: boolean ) - (>state<) - [ (prepare-result) ] [ ] [ drop empty? ] 2tri - [ 2drop >>result drop f ] - [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline - -TYPED: (prepare-object) ( type: integer -- object ) - [ element-data-read ] [ end-element ] bi ; inline - -! :: (read-object) ( type name state -- ) -! state peek-scope :> scope -! type (prepare-object) name scope set-at ; inline - -: (read-object) ( type name state -- ) - peek-scope [ (prepare-object) ] 2dip set-at ; inline - -TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean ) - read-cstring get-state - [ push-element ] - [ (read-object) t ] 3bi ; inline +TYPED: (read-object) ( type: integer name: string -- ) + [ element-data-read ] dip state get set-at ; inline recursive TYPED: (element-read) ( type: integer -- cont?: boolean ) dup T_EOO > - [ bson-not-eoo-element-read ] - [ drop bson-eoo-element-read ] if ; inline + [ read-cstring (read-object) t ] + [ drop f ] if ; inline recursive : read-elements ( -- ) read-byte (element-read) @@ -168,6 +104,6 @@ TYPED: (element-read) ( type: integer -- cont?: boolean ) PRIVATE> : stream>assoc ( exemplar -- assoc ) - read-int32 >>size - [ state [ read-elements ] with-variable ] - [ result>> ] bi ; + clone [ + state [ bson-object-data-read ] with-variable + ] keep ; From 221fb87fae0da3e77e365c0782035fa427fb9cc9 Mon Sep 17 00:00:00 2001 From: Dmitry Shubin Date: Sat, 12 Jun 2010 06:42:58 +0400 Subject: [PATCH 05/20] FUEL: improve highlighting and indentation for ERROR: --- misc/fuel/fuel-font-lock.el | 2 ++ misc/fuel/fuel-syntax.el | 6 +++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 8ccf50d0e0..d54b0cd337 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -59,6 +59,7 @@ (ratio constant "ratios") (declaration keyword "declaration words") (ebnf-form constant "EBNF: ... ;EBNF form") + (error-form warning "ERROR: ... ; form") (parsing-word keyword "parsing words") (postpone-body comment "postponed form") (setter-word function-name "setter words (>>foo)") @@ -132,6 +133,7 @@ (,fuel-syntax--float-regex . 'factor-font-lock-number) (,fuel-syntax--ratio-regex . 'factor-font-lock-ratio) (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) + (,fuel-syntax--error-regex 2 'factor-font-lock-error-form) (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word)) (,fuel-syntax--before-definition-regex (1 'factor-font-lock-type-name) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 0d77d9cc13..e2db30db3d 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -135,6 +135,9 @@ (fuel-syntax--second-word-regex '("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:"))) +(defconst fuel-syntax--error-regex + (fuel-syntax--second-word-regex '("ERROR:"))) + (defconst fuel-syntax--tuple-decl-regex "^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>") @@ -168,7 +171,8 @@ (defconst fuel-syntax--indent-def-starts '("" ":" "AFTER" "BEFORE" - "ENUM" "COM-INTERFACE" "CONSULT" + "COM-INTERFACE" "CONSULT" + "ENUM" "ERROR" "FROM" "FUNCTION:" "FUNCTION-ALIAS:" "INTERSECTION:" "M" "M:" "MACRO" "MACRO:" From 70b8a74208317dcf06e3cdafb19b722b46ce0496 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jun 2010 17:57:16 -0400 Subject: [PATCH 06/20] vm: have to be extra careful when messing with return addresses --- basis/cpu/x86/32/bootstrap.factor | 8 ++++--- basis/cpu/x86/64/bootstrap.factor | 9 ++++---- vm/callstack.cpp | 37 ++++++++++++++++++------------- vm/code_block_visitor.hpp | 11 ++++----- vm/gc.cpp | 8 ++++--- vm/slot_visitor.hpp | 27 ++++++++++++---------- vm/vm.hpp | 1 + 7 files changed, 57 insertions(+), 44 deletions(-) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 38c98913be..2b82fa8117 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -63,6 +63,9 @@ IN: bootstrap.x86 ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; +: jit-scrub-return ( n -- ) + ESP swap [+] 0 MOV ; + [ ! ctx-reg is preserved across the call because it is non-volatile ! in the C ABI @@ -130,6 +133,7 @@ IN: bootstrap.x86 ! Unwind stack frames ESP EDX MOV + 0 jit-scrub-return jit-jump-quot ] \ unwind-native-frames define-sub-primitive @@ -252,9 +256,7 @@ IN: bootstrap.x86 ! Contexts : jit-switch-context ( reg -- ) - ! Dummy return address -- it never gets returned to but it - ! must point to inside the current code block - ESP -4 [+] HEX: ffffffff MOV rc-absolute-cell rt-this jit-rel + -4 jit-scrub-return ! Save ds, rs registers jit-load-vm diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 7269e3240f..e81e924245 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -61,6 +61,9 @@ IN: bootstrap.x86 ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; +: jit-scrub-return ( n -- ) + RSP swap [+] 0 MOV ; + [ ! ctx-reg is preserved across the call because it is non-volatile ! in the C ABI @@ -111,6 +114,7 @@ IN: bootstrap.x86 ! Unwind stack frames RSP arg2 MOV + 0 jit-scrub-return ! Load VM pointer into vm-reg, since we're entering from ! C code @@ -228,10 +232,7 @@ IN: bootstrap.x86 ! Contexts : jit-switch-context ( reg -- ) - ! Dummy return address -- it never gets returned to but it - ! must point to inside the current code block - R11 0 [RIP+] LEA - RSP -8 [+] R11 MOV + -8 jit-scrub-return ! Save ds, rs registers jit-save-context diff --git a/vm/callstack.cpp b/vm/callstack.cpp index dd76714245..64c17d8661 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -108,7 +108,25 @@ stack_frame *factor_vm::frame_successor(stack_frame *frame) return (stack_frame *)((cell)frame - frame->size); } -/* Allocates memory */ +cell factor_vm::frame_offset(stack_frame *frame) +{ + char *entry_point = (char *)frame_code(frame)->entry_point(); + char *return_address = (char *)FRAME_RETURN_ADDRESS(frame,this); + if(return_address) + return return_address - entry_point; + else + return (cell)-1; +} + +void factor_vm::set_frame_offset(stack_frame *frame, cell offset) +{ + char *entry_point = (char *)frame_code(frame)->entry_point(); + if(offset == (cell)-1) + FRAME_RETURN_ADDRESS(frame,this) = NULL; + else + FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset; +} + cell factor_vm::frame_scan(stack_frame *frame) { switch(frame_type(frame)) @@ -120,13 +138,7 @@ cell factor_vm::frame_scan(stack_frame *frame) obj = obj.as()->def; if(obj.type_p(QUOTATION_TYPE)) - { - char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this); - char *quot_entry_point = (char *)frame_code(frame)->entry_point(); - - return tag_fixnum(quot_code_offset_to_scan( - obj.value(),(cell)(return_addr - quot_entry_point))); - } + return tag_fixnum(quot_code_offset_to_scan(obj.value(),frame_offset(frame))); else return false_object; } @@ -138,11 +150,6 @@ cell factor_vm::frame_scan(stack_frame *frame) } } -cell factor_vm::frame_offset(stack_frame *frame) -{ - return (cell)FRAME_RETURN_ADDRESS(frame,this) - (cell)frame_code(frame)->entry_point(); -} - struct stack_frame_accumulator { factor_vm *parent; growable_array frames; @@ -209,9 +216,9 @@ void factor_vm::primitive_set_innermost_stack_frame_quot() jit_compile_quot(quot.value(),true); stack_frame *inner = innermost_stack_frame(callstack.untagged()); - cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point; + cell offset = frame_offset(inner); inner->entry_point = quot->entry_point; - FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset; + set_frame_offset(inner,offset); } void factor_vm::primitive_callstack_bounds() diff --git a/vm/code_block_visitor.hpp b/vm/code_block_visitor.hpp index b6581b8c8f..8b48d3672f 100644 --- a/vm/code_block_visitor.hpp +++ b/vm/code_block_visitor.hpp @@ -42,13 +42,10 @@ struct call_frame_code_block_visitor { void operator()(stack_frame *frame) { - code_block *old_block = parent->frame_code(frame); - cell offset = (char *)FRAME_RETURN_ADDRESS(frame,parent) - (char *)old_block; - - const code_block *new_block = fixup.fixup_code(old_block); - frame->entry_point = new_block->entry_point(); - - FRAME_RETURN_ADDRESS(frame,parent) = (char *)new_block + offset; + cell offset = parent->frame_offset(frame); + code_block *compiled = fixup.fixup_code(parent->frame_code(frame)); + frame->entry_point = compiled->entry_point(); + parent->set_frame_offset(frame,offset); } }; diff --git a/vm/gc.cpp b/vm/gc.cpp index 24f773b226..766940a2d7 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -207,13 +207,15 @@ struct call_frame_scrubber { void operator()(stack_frame *frame) { - const code_block *compiled = parent->frame_code(frame); + cell return_address = parent->frame_offset(frame); + if(return_address == (cell)-1) + return; + + code_block *compiled = parent->frame_code(frame); gc_info *info = compiled->block_gc_info(); - cell return_address = parent->frame_offset(frame); assert(return_address < compiled->size()); int index = info->return_address_index(return_address); - if(index != -1) ctx->scrub_stacks(info,index); } diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp index 8d1c27a55c..ba78b4b76c 100644 --- a/vm/slot_visitor.hpp +++ b/vm/slot_visitor.hpp @@ -284,23 +284,26 @@ struct call_frame_slot_visitor { */ void operator()(stack_frame *frame) { - const code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame)); - gc_info *info = compiled->block_gc_info(); cell return_address = parent->frame_offset(frame); + if(return_address == (cell)-1) + return; + + code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame)); + gc_info *info = compiled->block_gc_info(); + assert(return_address < compiled->size()); int index = info->return_address_index(return_address); + if(index == -1) + return; - if(index != -1) + u8 *bitmap = info->gc_info_bitmap(); + cell base = info->spill_slot_base(index); + cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1); + + for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++) { - u8 *bitmap = info->gc_info_bitmap(); - cell base = info->spill_slot_base(index); - cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1); - - for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++) - { - if(bitmap_p(bitmap,base + spill_slot)) - visitor->visit_handle(&stack_pointer[spill_slot]); - } + if(bitmap_p(bitmap,base + spill_slot)) + visitor->visit_handle(&stack_pointer[spill_slot]); } } }; diff --git a/vm/vm.hpp b/vm/vm.hpp index 5c2b0697f7..147647b528 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -597,6 +597,7 @@ struct factor_vm stack_frame *frame_successor(stack_frame *frame); cell frame_scan(stack_frame *frame); cell frame_offset(stack_frame *frame); + void set_frame_offset(stack_frame *frame, cell offset); void primitive_callstack_to_array(); stack_frame *innermost_stack_frame(callstack *stack); void primitive_innermost_stack_frame_executing(); From 71cc16df2a5a87388c31cc0d8f2495ca4689ebdc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jun 2010 18:11:39 -0400 Subject: [PATCH 07/20] vocabs.loader: tweak docs --- core/vocabs/loader/loader-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 423abbc277..d3736db9bf 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -11,7 +11,7 @@ $nl $nl "The second way is to create a configuration file. You can list additional vocabulary roots in a file that Factor reads at startup:" { $subsections "factor-roots" } -"Finally, you can add vocabulary roots dynamically using a word:" +"Finally, you can add vocabulary roots by calling a word from your " { $snippet "factor-rc" } " file (see " { $link "factor-rc" } "):" { $subsections add-vocab-root } ; ARTICLE: "vocabs.roots" "Vocabulary roots" From 173880168ae9a692802894c2d90acf7e990411c7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 13 Jun 2010 20:41:46 -0700 Subject: [PATCH 08/20] sequences.cords: fall back to generic sequence methods when both arguments to binary cord ops aren't cords --- basis/sequences/cords/cords.factor | 71 ++++++++++++++++-------------- 1 file changed, 38 insertions(+), 33 deletions(-) diff --git a/basis/sequences/cords/cords.factor b/basis/sequences/cords/cords.factor index 5be500abd4..766fbe87c0 100644 --- a/basis/sequences/cords/cords.factor +++ b/basis/sequences/cords/cords.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences sorting binary-search fry math -math.order arrays classes combinators kernel functors math.functions -math.vectors ; +math.order arrays classes combinators kernel functors locals +math.functions math.vectors ; IN: sequences.cords MIXIN: cord @@ -47,57 +47,62 @@ M: T cord-append [ [ head>> ] dip call ] [ [ tail>> ] dip call ] 2bi cord-append ; inline -: cord-2map ( cord cord quot -- cord' ) - [ [ [ head>> ] bi@ ] dip call ] - [ [ [ tail>> ] bi@ ] dip call ] 3bi cord-append ; inline +:: cord-2map ( cord-a cord-b quot fallback -- cord' ) + cord-a cord-b 2dup [ cord? ] both? [ + [ [ head>> ] bi@ quot call ] + [ [ tail>> ] bi@ quot call ] 2bi cord-append + ] [ fallback call ] if ; inline : cord-both ( cord quot -- h t ) [ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline -: cord-2both ( cord cord quot -- h t ) - [ [ [ head>> ] bi@ ] dip call ] - [ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline +:: cord-2both ( cord-a cord-b quot combine fallback -- result ) + cord-a cord-b 2dup [ cord? ] both? [ + [ [ head>> ] bi@ quot call ] + [ [ tail>> ] bi@ quot call ] 2bi combine call + ] [ fallback call ] if ; inline -M: cord v+ [ v+ ] cord-2map ; inline -M: cord v- [ v- ] cord-2map ; inline +M: cord v+ [ v+ ] [ call-next-method ] cord-2map ; inline +M: cord v- [ v- ] [ call-next-method ] cord-2map ; inline M: cord vneg [ vneg ] cord-map ; inline -M: cord v+- [ v+- ] cord-2map ; inline -M: cord vs+ [ vs+ ] cord-2map ; inline -M: cord vs- [ vs- ] cord-2map ; inline -M: cord vs* [ vs* ] cord-2map ; inline -M: cord v* [ v* ] cord-2map ; inline -M: cord v/ [ v/ ] cord-2map ; inline -M: cord vmin [ vmin ] cord-2map ; inline -M: cord vmax [ vmax ] cord-2map ; inline -M: cord v. [ v. ] cord-2both + ; inline +M: cord v+- [ v+- ] [ call-next-method ] cord-2map ; inline +M: cord vs+ [ vs+ ] [ call-next-method ] cord-2map ; inline +M: cord vs- [ vs- ] [ call-next-method ] cord-2map ; inline +M: cord vs* [ vs* ] [ call-next-method ] cord-2map ; inline +M: cord v* [ v* ] [ call-next-method ] cord-2map ; inline +M: cord v/ [ v/ ] [ call-next-method ] cord-2map ; inline +M: cord vmin [ vmin ] [ call-next-method ] cord-2map ; inline +M: cord vmax [ vmax ] [ call-next-method ] cord-2map ; inline +M: cord v. + [ v. ] [ + ] [ call-next-method ] cord-2both ; inline M: cord vsqrt [ vsqrt ] cord-map ; inline M: cord sum [ sum ] cord-both + ; inline M: cord vabs [ vabs ] cord-map ; inline -M: cord vbitand [ vbitand ] cord-2map ; inline -M: cord vbitandn [ vbitandn ] cord-2map ; inline -M: cord vbitor [ vbitor ] cord-2map ; inline -M: cord vbitxor [ vbitxor ] cord-2map ; inline +M: cord vbitand [ vbitand ] [ call-next-method ] cord-2map ; inline +M: cord vbitandn [ vbitandn ] [ call-next-method ] cord-2map ; inline +M: cord vbitor [ vbitor ] [ call-next-method ] cord-2map ; inline +M: cord vbitxor [ vbitxor ] [ call-next-method ] cord-2map ; inline M: cord vbitnot [ vbitnot ] cord-map ; inline -M: cord vand [ vand ] cord-2map ; inline -M: cord vandn [ vandn ] cord-2map ; inline -M: cord vor [ vor ] cord-2map ; inline -M: cord vxor [ vxor ] cord-2map ; inline +M: cord vand [ vand ] [ call-next-method ] cord-2map ; inline +M: cord vandn [ vandn ] [ call-next-method ] cord-2map ; inline +M: cord vor [ vor ] [ call-next-method ] cord-2map ; inline +M: cord vxor [ vxor ] [ call-next-method ] cord-2map ; inline M: cord vnot [ vnot ] cord-map ; inline M: cord vlshift '[ _ vlshift ] cord-map ; inline M: cord vrshift '[ _ vrshift ] cord-map ; inline M: cord (vmerge-head) [ head>> ] bi@ (vmerge) cord-append ; inline M: cord (vmerge-tail) [ tail>> ] bi@ (vmerge) cord-append ; inline -M: cord v<= [ v<= ] cord-2map ; inline -M: cord v< [ v< ] cord-2map ; inline -M: cord v= [ v= ] cord-2map ; inline -M: cord v> [ v> ] cord-2map ; inline -M: cord v>= [ v>= ] cord-2map ; inline -M: cord vunordered? [ vunordered? ] cord-2map ; inline +M: cord v<= [ v<= ] [ call-next-method ] cord-2map ; inline +M: cord v< [ v< ] [ call-next-method ] cord-2map ; inline +M: cord v= [ v= ] [ call-next-method ] cord-2map ; inline +M: cord v> [ v> ] [ call-next-method ] cord-2map ; inline +M: cord v>= [ v>= ] [ call-next-method ] cord-2map ; inline +M: cord vunordered? [ vunordered? ] [ call-next-method ] cord-2map ; inline M: cord vany? [ vany? ] cord-both or ; inline M: cord vall? [ vall? ] cord-both and ; inline M: cord vnone? [ vnone? ] cord-both and ; inline From 6ce01d0b0d32416f6d68f1394844219377f2c0a5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Jun 2010 14:23:55 -0700 Subject: [PATCH 09/20] typed: include value that raised the error in type-mismatch-errors --- basis/typed/prettyprint/prettyprint.factor | 24 +++++++++++++++++++++- basis/typed/typed-tests.factor | 13 +++++++----- basis/typed/typed.factor | 7 ++----- 3 files changed, 33 insertions(+), 11 deletions(-) diff --git a/basis/typed/prettyprint/prettyprint.factor b/basis/typed/prettyprint/prettyprint.factor index 8a7ff5b7b2..4bb8814e4c 100644 --- a/basis/typed/prettyprint/prettyprint.factor +++ b/basis/typed/prettyprint/prettyprint.factor @@ -1,4 +1,5 @@ -USING: definitions kernel locals.definitions see see.private typed words ; +USING: definitions kernel locals.definitions see see.private typed words +summary make accessors classes ; IN: typed.prettyprint PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ; @@ -9,3 +10,24 @@ M: typed-lambda-word definer drop \ TYPED:: \ ; ; M: typed-word definition "typed-def" word-prop ; M: typed-word declarations. "typed-word" word-prop declarations. ; +M: input-mismatch-error summary + [ + "Typed word “" % + dup word>> name>> % + "” expected input value of type " % + dup expected-type>> name>> % + " but got " % + dup value>> class name>> % + drop + ] "" make ; + +M: output-mismatch-error summary + [ + "Typed word “" % + dup word>> name>> % + "” expected to output value of type " % + dup expected-type>> name>> % + " but gave " % + dup value>> class name>> % + drop + ] "" make ; diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index bca1136ee6..70edcf2334 100644 --- a/basis/typed/typed-tests.factor +++ b/basis/typed/typed-tests.factor @@ -1,6 +1,6 @@ USING: accessors effects eval kernel layouts math namespaces -quotations tools.test typed words words.symbol -compiler.tree.debugger prettyprint definitions compiler.units ; +quotations tools.test typed words words.symbol combinators.short-circuit +compiler.tree.debugger prettyprint definitions compiler.units sequences ; IN: typed.tests TYPED: f+ ( a: float b: float -- c: float ) @@ -24,14 +24,17 @@ TYPED: dee ( x: tweedle-dee -- y ) TYPED: dum ( x: tweedle-dum -- y ) drop \ tweedle-dum ; -[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with -[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with +[ \ tweedle-dum new dee ] +[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with +[ \ tweedle-dee new dum ] +[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with TYPED: dumdum ( x -- y: tweedle-dum ) drop \ tweedle-dee new ; -[ f dumdum ] [ output-mismatch-error? ] must-fail-with +[ f dumdum ] +[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with TYPED:: f+locals ( a: float b: float -- c: float ) a b + ; diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 50da7b1bad..fe2ba41722 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -7,7 +7,7 @@ locals.parser macros stack-checker.dependencies ; FROM: classes.tuple.private => tuple-layout ; IN: typed -ERROR: type-mismatch-error word expected-types ; +ERROR: type-mismatch-error value expected-type word expected-types ; ERROR: input-mismatch-error < type-mismatch-error ; ERROR: output-mismatch-error < type-mismatch-error ; @@ -28,9 +28,6 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ; : typed-stack-effect? ( effect -- ? ) [ object = ] all? not ; -: input-mismatch-quot ( word types -- quot ) - [ input-mismatch-error ] 2curry ; - : depends-on-unboxing ( class -- ) [ dup tuple-layout depends-on-tuple-layout ] [ depends-on-final ] @@ -47,7 +44,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ; :: unboxer ( error-quot word types type -- quot ) type "coercer" word-prop [ ] or - [ dup type instance? [ word types error-quot call ] unless ] + type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ] type (unboxer) compose compose ; From f9bd9efd7c8c91b09d7840b70e90e993fcd88fd6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Jun 2010 16:12:48 -0700 Subject: [PATCH 10/20] prettyprint.backend: add 1 to nesting-limit while pprinting hashtables 'cause H{ ~array~ ~array~ } is kind of useless --- basis/prettyprint/backend/backend.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 7d0cb40576..201a1c28d2 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -226,7 +226,9 @@ M: object pprint-object ( obj -- ) M: object pprint* pprint-object ; M: vector pprint* pprint-object ; M: byte-vector pprint* pprint-object ; -M: hashtable pprint* pprint-object ; +M: hashtable pprint* + nesting-limit inc + [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ; M: curry pprint* pprint-object ; M: compose pprint* pprint-object ; M: hash-set pprint* pprint-object ; From e86f434f26886a737aec8bb8555d32a938ae21da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Jun 2010 17:36:08 -0400 Subject: [PATCH 11/20] Add GC maps to ##box, ##box-long-long, ##alien-invoke, ##alien-indirect and ##call-gc; remove ##gc-map instruction --- basis/compiler/cfg/builder/alien/alien.factor | 4 +- .../cfg/builder/alien/boxing/boxing.factor | 6 +-- .../cfg/finalization/finalization.factor | 10 ++-- basis/compiler/cfg/gc-checks/gc-checks.factor | 38 +++------------ .../cfg/instructions/instructions.factor | 33 +++++++++---- .../linear-scan/assignment/assignment.factor | 6 ++- basis/compiler/cfg/liveness/liveness.factor | 29 +++++++++--- .../stacks/uninitialized/uninitialized.factor | 30 ++++++------ basis/compiler/codegen/codegen.factor | 1 - .../compiler/codegen/fixup/fixup-tests.factor | 15 ++++-- basis/compiler/codegen/fixup/fixup.factor | 46 +++++++++++-------- basis/cpu/architecture/architecture.factor | 15 +++--- basis/cpu/x86/32/32.factor | 27 +++++------ basis/cpu/x86/64/64.factor | 23 +++++----- basis/cpu/x86/x86.factor | 11 ++--- vm/collector.hpp | 2 + vm/contexts.cpp | 10 ++++ vm/slot_visitor.hpp | 8 ++++ 18 files changed, 176 insertions(+), 138 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 7bf45e959a..04ac2bf496 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -102,7 +102,7 @@ M: #alien-invoke emit-node [ { [ caller-parameters ] - [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ] + [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ] [ emit-stack-frame ] [ box-return* ] } cleave @@ -111,7 +111,7 @@ M: #alien-invoke emit-node M:: #alien-indirect emit-node ( node -- ) node [ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src - [ caller-parameters src ##alien-indirect ] + [ caller-parameters src ##alien-indirect ] [ emit-stack-frame ] [ box-return* ] tri diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 6f5f46b9c1..1992d7539a 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -105,13 +105,13 @@ M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ; GENERIC: box ( vregs reps c-type -- dst ) M: c-type box - [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ; + [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ; M: long-long-type box - [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ; + [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ; M: struct-c-type box - '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip + '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip implode-struct ; GENERIC: box-parameter ( vregs reps c-type -- dst ) diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 5440ba6eef..83bcc0b0b1 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -1,15 +1,17 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.cfg.gc-checks compiler.cfg.representations -compiler.cfg.save-contexts compiler.cfg.ssa.destruction -compiler.cfg.build-stack-frame compiler.cfg.linear-scan -compiler.cfg.scheduling ; +USING: kernel compiler.cfg.gc-checks +compiler.cfg.representations compiler.cfg.save-contexts +compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame +compiler.cfg.linear-scan compiler.cfg.scheduling +compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.finalization : finalize-cfg ( cfg -- cfg' ) select-representations schedule-instructions insert-gc-checks + dup compute-uninitialized-sets insert-save-contexts destruct-ssa linear-scan diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 60f81f77d9..50cd67567c 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -9,10 +9,7 @@ compiler.cfg.registers compiler.cfg.utilities compiler.cfg.comparisons compiler.cfg.instructions -compiler.cfg.predecessors -compiler.cfg.liveness -compiler.cfg.liveness.ssa -compiler.cfg.stacks.uninitialized ; +compiler.cfg.predecessors ; IN: compiler.cfg.gc-checks >instructions ; -: scrubbed ( uninitialized-locs -- scrub-d scrub-r ) - [ ds-loc? ] partition [ [ n>> ] map ] bi@ ; - -: ( uninitialized-locs gc-roots -- bb ) - [ ] 2dip - [ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make +: ( -- bb ) + + [ ##call-gc ##branch ] V{ } make >>instructions t >>unlikely? ; :: insert-guard ( body check bb -- ) @@ -69,7 +63,7 @@ IN: compiler.cfg.gc-checks check predecessors>> [ bb check update-successors ] each ; -: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- ) +: (insert-gc-check) ( phis size bb -- ) [ [ ] 2dip ] dip insert-guard ; GENERIC: allocation-size* ( insn -- n ) @@ -85,35 +79,17 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ; [ ##allocation? ] filter [ allocation-size* data-alignment get align ] map-sum ; -: gc-live-in ( bb -- vregs ) - [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi - append ; - -: live-tagged ( bb -- vregs ) - gc-live-in [ rep-of tagged-rep? ] filter ; - : remove-phis ( bb -- phis ) [ [ ##phi? ] partition ] change-instructions drop ; : insert-gc-check ( bb -- ) - { - [ uninitialized-locs ] - [ live-tagged ] - [ remove-phis ] - [ allocation-size ] - [ ] - } cleave - (insert-gc-check) ; + [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ; PRIVATE> : insert-gc-checks ( cfg -- cfg' ) dup blocks-with-gc [ - [ - needs-predecessors - dup compute-ssa-live-sets - dup compute-uninitialized-sets - ] dip + [ needs-predecessors ] dip [ insert-gc-check ] each cfg-changed ] unless-empty ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index b46a42d8d5..39d2ab81cd 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -670,27 +670,28 @@ literal: size align offset ; INSN: ##box def: dst/tagged-rep use: src -literal: boxer rep ; +literal: boxer rep gc-map ; INSN: ##box-long-long def: dst/tagged-rep use: src1/int-rep src2/int-rep -literal: boxer ; +literal: boxer gc-map ; INSN: ##allot-byte-array def: dst/tagged-rep -literal: size ; +literal: size gc-map ; INSN: ##prepare-var-args ; INSN: ##alien-invoke -literal: symbols dll ; +literal: symbols dll gc-map ; INSN: ##cleanup literal: n ; INSN: ##alien-indirect -use: src/int-rep ; +use: src/int-rep +literal: gc-map ; INSN: ##alien-assembly literal: quot ; @@ -819,10 +820,7 @@ INSN: ##check-nursery-branch literal: size cc temp: temp1/int-rep temp2/int-rep ; -INSN: ##call-gc ; - -INSN: ##gc-map -literal: scrub-d scrub-r gc-roots ; +INSN: ##call-gc literal: gc-map ; ! Spills and reloads, inserted by register allocator TUPLE: spill-slot { n integer } ; @@ -860,6 +858,23 @@ UNION: conditional-branch-insn UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; +! Instructions that contain subroutine calls to functions which +! allocate memory +UNION: gc-map-insn +##call-gc +##alien-invoke +##alien-indirect +##box +##box-long-long +##allot-byte-array ; + +M: gc-map-insn clone call-next-method [ clone ] change-gc-map ; + +! Each one has a gc-map slot +TUPLE: gc-map scrub-d scrub-r gc-roots ; + +: ( -- gc-map ) gc-map new ; + ! Instructions that clobber registers. They receive inputs and ! produce outputs in spill slots. UNION: hairy-clobber-insn diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index e6d220a90c..cab4438ec9 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -142,8 +142,10 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] M: vreg-insn assign-registers-in-insn [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ; -M: ##gc-map assign-registers-in-insn - [ [ vreg>reg ] map ] change-gc-roots drop ; +M: gc-map-insn assign-registers-in-insn + [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ] + [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ] + bi ; M: insn assign-registers-in-insn drop ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index a10b48cc0c..1a5287355d 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,25 +1,40 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors assocs sequences sets compiler.cfg.def-use compiler.cfg.dataflow-analysis -compiler.cfg.instructions ; +compiler.cfg.instructions compiler.cfg.registers +cpu.architecture ; IN: compiler.cfg.liveness ! See http://en.wikipedia.org/wiki/Liveness_analysis -! Do not run after SSA construction +! Do not run after SSA construction; compiler.cfg.liveness.ssa +! should be used instead. The transfer-liveness word is used +! by SSA liveness too, so it handles ##phi instructions. BACKWARD-ANALYSIS: live -GENERIC: insn-liveness ( live-set insn -- ) +GENERIC: visit-insn ( live-set insn -- live-set ) : kill-defs ( live-set insn -- live-set ) - defs-vreg [ over delete-at ] when* ; + defs-vreg [ over delete-at ] when* ; inline : gen-uses ( live-set insn -- live-set ) - dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ; + uses-vregs [ over conjoin ] each ; inline + +M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ; + +: fill-gc-map ( live-set insn -- live-set ) + gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ; + +M: gc-map-insn visit-insn + [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ; + +M: ##phi visit-insn kill-defs ; + +M: insn visit-insn drop ; : transfer-liveness ( live-set instructions -- live-set' ) - [ clone ] [ ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ; + [ clone ] [ ] bi* [ visit-insn ] each ; : local-live-in ( instructions -- live-set ) [ H{ } ] dip transfer-liveness keys ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 982e9b872c..7498cddf10 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -9,11 +9,17 @@ IN: compiler.cfg.stacks.uninitialized ! Consider the following sequence of instructions: ! ##inc-d 2 -! ##gc +! ... +! ##allot ! ##replace ... D 0 ! ##replace ... D 1 -! The GC check runs before stack locations 0 and 1 have been initialized, -! and it needs to zero them out so that GC doesn't try to trace them. +! The GC check runs before stack locations 0 and 1 have been +! initialized, and so the GC needs to scrub them so that they +! don't get traced. This is achieved by computing uninitialized +! locations with a dataflow analysis, and recording the +! information in GC maps. The scrub_contexts() method on +! vm/gc.cpp reads this information from GC maps and performs +! the scrubbing. > ds-loc handle-inc ; - M: ##inc-r visit-insn n>> rs-loc handle-inc ; ERROR: uninitialized-peek insn ; @@ -46,6 +51,12 @@ M: ##peek visit-insn visit-peek ; M: ##replace visit-insn visit-replace ; M: ##replace-imm visit-insn visit-replace ; +M: gc-map-insn visit-insn + gc-map>> + ds-loc get clone >>scrub-d + rs-loc get clone >>scrub-r + drop ; + M: insn visit-insn drop ; : prepare ( pair -- ) @@ -59,9 +70,6 @@ M: insn visit-insn drop ; : (join-sets) ( seq1 seq2 -- seq ) 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; -: (uninitialized-locs) ( seq quot -- seq' ) - [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline - PRIVATE> FORWARD-ANALYSIS: uninitialized @@ -71,11 +79,3 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) M: uninitialized-analysis join-sets ( sets analysis -- pair ) 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; - -: uninitialized-locs ( bb -- locs ) - uninitialized-in dup [ - first2 - [ [ ] (uninitialized-locs) ] - [ [ ] (uninitialized-locs) ] - bi* append f like - ] when ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index f33999ab89..68b01beed9 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -258,7 +258,6 @@ CODEGEN: ##restore-context %restore-context CODEGEN: ##vm-field %vm-field CODEGEN: ##set-vm-field %set-vm-field CODEGEN: ##alien-global %alien-global -CODEGEN: ##gc-map %gc-map CODEGEN: ##call-gc %call-gc CODEGEN: ##spill %spill CODEGEN: ##reload %reload diff --git a/basis/compiler/codegen/fixup/fixup-tests.factor b/basis/compiler/codegen/fixup/fixup-tests.factor index fcb33e4937..f068861126 100644 --- a/basis/compiler/codegen/fixup/fixup-tests.factor +++ b/basis/compiler/codegen/fixup/fixup-tests.factor @@ -1,6 +1,7 @@ USING: namespaces byte-arrays make compiler.codegen.fixup bit-arrays accessors classes.struct tools.test kernel math -sequences alien.c-types specialized-arrays boxes ; +sequences alien.c-types specialized-arrays boxes +compiler.cfg.instructions system cpu.architecture ; SPECIALIZED-ARRAY: uint IN: compiler.codegen.fixup.tests @@ -10,19 +11,23 @@ STRUCT: gc-info { gc-root-count uint } { return-address-count uint } ; +SINGLETON: fake-cpu + +fake-cpu \ cpu set + +M: fake-cpu gc-root-offsets ; + [ ] [ [ init-fixup 50 % - { { } { } { } } set-next-gc-map - gc-map-here + T{ gc-map f B{ } B{ } V{ } } gc-map-here 50 % - { { 0 4 } { 1 } { 1 3 } } set-next-gc-map - gc-map-here + T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here emit-gc-info ] B{ } make diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index f0730e91d8..b4ef317b67 100644 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -4,8 +4,9 @@ USING: arrays bit-arrays byte-arrays byte-vectors generic assocs hashtables io.binary kernel kernel.private math namespaces make sequences words quotations strings alien.accessors alien.strings layouts system combinators math.bitwise math.order -combinators.smart accessors growable fry compiler.constants -memoize boxes ; +combinators.short-circuit combinators.smart accessors growable +fry memoize compiler.constants compiler.cfg.instructions +cpu.architecture ; IN: compiler.codegen.fixup ! Utilities @@ -149,30 +150,37 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ; ! uint ! uint -SYMBOLS: next-gc-map return-addresses gc-maps ; +SYMBOLS: return-addresses gc-maps ; -: gc-map? ( triple -- ? ) +: gc-map-needed? ( gc-map -- ? ) ! If there are no stack locations to scrub and no GC roots, ! there's no point storing the GC map. - [ empty? not ] any? ; + dup [ + { + [ scrub-d>> empty? ] + [ scrub-r>> empty? ] + [ gc-roots>> empty? ] + } 1&& not + ] when ; -: gc-map-here ( -- ) - next-gc-map get box> dup gc-map? [ +: gc-map-here ( gc-map -- ) + dup gc-map-needed? [ gc-maps get push compiled-offset return-addresses get push ] [ drop ] if ; -: set-next-gc-map ( gc-map -- ) next-gc-map get >box ; +: emit-scrub ( seqs -- n ) + ! seqs is a sequence of sequences of 0/1 + dup [ length ] [ max ] map-reduce + [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ; : integers>bits ( seq n -- bit-array ) [ '[ [ t ] dip _ set-nth ] each ] keep ; -: emit-bitmap ( seqs -- n ) +: emit-gc-roots ( seqs -- n ) ! seqs is a sequence of sequences of integers 0..n-1 - [ 0 ] [ - dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce - [ '[ _ integers>bits % ] each ] keep - ] if-empty ; + dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce + [ '[ _ integers>bits % ] each ] keep ; : emit-uint ( n -- ) building get push-uint ; @@ -182,9 +190,9 @@ SYMBOLS: next-gc-map return-addresses gc-maps ; return-addresses get empty? [ 0 emit-uint ] [ gc-maps get [ - [ [ first ] map emit-bitmap ] - [ [ second ] map emit-bitmap ] - [ [ third ] map emit-bitmap ] tri + [ [ scrub-d>> ] map emit-scrub ] + [ [ scrub-r>> ] map emit-scrub ] + [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri ] ?{ } make underlying>> % return-addresses get [ emit-uint ] each [ emit-uint ] tri@ @@ -208,12 +216,10 @@ SYMBOLS: next-gc-map return-addresses gc-maps ; BV{ } clone relocation-table set V{ } clone binary-literal-table set V{ } clone return-addresses set - V{ } clone gc-maps set - next-gc-map set ; + V{ } clone gc-maps set ; : check-fixup ( seq -- ) - length data-alignment get mod 0 assert= - next-gc-map get occupied>> f assert= ; + length data-alignment get mod 0 assert= ; : with-fixup ( quot -- code ) '[ diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 279947bd43..931dccece1 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -225,6 +225,8 @@ M: object vm-stack-space 0 ; ! %store-memory work HOOK: complex-addressing? cpu ( -- ? ) +HOOK: gc-root-offsets cpu ( seq -- seq' ) + HOOK: %load-immediate cpu ( reg val -- ) HOOK: %load-reference cpu ( reg obj -- ) HOOK: %load-float cpu ( reg val -- ) @@ -488,8 +490,7 @@ HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- ) ! GC checks HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- ) -HOOK: %gc-map cpu ( scrub-d scrub-r gc-roots -- ) -HOOK: %call-gc cpu ( -- ) +HOOK: %call-gc cpu ( gc-map -- ) HOOK: %prologue cpu ( n -- ) HOOK: %epilogue cpu ( n -- ) @@ -595,11 +596,11 @@ HOOK: %local-allot cpu ( dst size align offset -- ) ! Call a function to convert a value into a tagged pointer, ! possibly allocating a bignum, float, or alien instance, ! which is then pushed on the data stack -HOOK: %box cpu ( dst src func rep -- ) +HOOK: %box cpu ( dst src func rep gc-map -- ) -HOOK: %box-long-long cpu ( dst src1 src2 func -- ) +HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- ) -HOOK: %allot-byte-array cpu ( dst size -- ) +HOOK: %allot-byte-array cpu ( dst size gc-map -- ) HOOK: %restore-context cpu ( temp1 temp2 -- ) @@ -609,13 +610,13 @@ HOOK: %prepare-var-args cpu ( -- ) M: object %prepare-var-args ; -HOOK: %alien-invoke cpu ( function library -- ) +HOOK: %alien-invoke cpu ( function library gc-map -- ) HOOK: %cleanup cpu ( n -- ) M: object %cleanup ( n -- ) drop ; -HOOK: %alien-indirect cpu ( src -- ) +HOOK: %alien-indirect cpu ( src gc-map -- ) HOOK: %load-reg-param cpu ( dst reg rep -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 50835affb0..48cc88a4f8 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -134,7 +134,7 @@ M: x86.32 %store-reg-param ( src reg rep -- ) EAX src tagged-rep %copy 4 save-vm-ptr 0 stack@ EAX MOV - func f %alien-invoke ; + func f f %alien-invoke ; M:: x86.32 %unbox ( dst src func rep -- ) src func call-unbox-func @@ -146,36 +146,37 @@ M:: x86.32 %unbox-long-long ( src out func -- ) EAX out int-rep %copy 4 stack@ EAX MOV 8 save-vm-ptr - func f %alien-invoke ; + func f f %alien-invoke ; -M:: x86.32 %box ( dst src func rep -- ) +M:: x86.32 %box ( dst src func rep gc-map -- ) rep rep-size save-vm-ptr src rep %store-return 0 stack@ rep %load-return - func f %alien-invoke + func f gc-map %alien-invoke dst EAX tagged-rep %copy ; -M:: x86.32 %box-long-long ( dst src1 src2 func -- ) +M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) 8 save-vm-ptr EAX src1 int-rep %copy 0 stack@ EAX int-rep %copy EAX src2 int-rep %copy 4 stack@ EAX int-rep %copy - func f %alien-invoke + func f gc-map %alien-invoke dst EAX tagged-rep %copy ; -M:: x86.32 %allot-byte-array ( dst size -- ) +M:: x86.32 %allot-byte-array ( dst size gc-map -- ) 4 save-vm-ptr 0 stack@ size MOV - "allot_byte_array" f %alien-invoke + "allot_byte_array" f gc-map %alien-invoke dst EAX tagged-rep %copy ; -M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; +M: x86.32 %alien-invoke + [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr 4 stack@ 0 MOV - "begin_callback" f %alien-invoke ; + "begin_callback" f f %alien-invoke ; M: x86.32 %alien-callback ( quot -- ) [ EAX ] dip %load-reference @@ -183,7 +184,7 @@ M: x86.32 %alien-callback ( quot -- ) M: x86.32 %end-callback ( -- ) 0 save-vm-ptr - "end_callback" f %alien-invoke ; + "end_callback" f f %alien-invoke ; GENERIC: float-function-param ( n dst src -- ) @@ -198,13 +199,13 @@ M:: register float-function-param ( n dst src -- ) M:: x86.32 %unary-float-function ( dst src func -- ) 0 dst src float-function-param - func "libm" load-library %alien-invoke + func "libm" load-library f %alien-invoke dst double-rep %load-return ; M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) 0 dst src1 float-function-param 8 dst src2 float-function-param - func "libm" load-library %alien-invoke + func "libm" load-library f %alien-invoke dst double-rep %load-return ; : funny-large-struct-return? ( return abi -- ? ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 65acdfbeb9..7a5e8a1af3 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -90,30 +90,29 @@ M:: x86.64 %store-reg-param ( src reg rep -- ) M:: x86.64 %unbox ( dst src func rep -- ) param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr - func f %alien-invoke + func f f %alien-invoke dst rep %load-return ; -M:: x86.64 %box ( dst src func rep -- ) +M:: x86.64 %box ( dst src func rep gc-map -- ) 0 rep reg-class-of cdecl param-regs at nth src rep %copy rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr - func f %alien-invoke + func f gc-map %alien-invoke dst int-rep %load-return ; -M:: x86.64 %allot-byte-array ( dst size -- ) +M:: x86.64 %allot-byte-array ( dst size gc-map -- ) param-reg-0 size MOV param-reg-1 %mov-vm-ptr - "allot_byte_array" f %alien-invoke + "allot_byte_array" f gc-map %alien-invoke dst int-rep %load-return ; M: x86.64 %alien-invoke - R11 0 MOV - rc-absolute-cell rel-dlsym - R11 CALL ; + [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip + gc-map-here ; M: x86.64 %begin-callback ( -- ) param-reg-0 %mov-vm-ptr param-reg-1 0 MOV - "begin_callback" f %alien-invoke ; + "begin_callback" f f %alien-invoke ; M: x86.64 %alien-callback ( quot -- ) [ param-reg-0 ] dip %load-reference @@ -121,14 +120,14 @@ M: x86.64 %alien-callback ( quot -- ) M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr - "end_callback" f %alien-invoke ; + "end_callback" f f %alien-invoke ; : float-function-param ( i src -- ) [ float-regs cdecl param-regs at nth ] dip double-rep %copy ; M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param - func "libm" load-library %alien-invoke + func "libm" load-library f %alien-invoke dst double-rep %load-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) @@ -136,7 +135,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! src2 is always a spill slot 0 src1 float-function-param 1 src2 float-function-param - func "libm" load-library %alien-invoke + func "libm" load-library f %alien-invoke dst double-rep %load-return ; M: x86.64 long-long-on-stack? f ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 05251818b5..d3adcf3960 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -480,13 +480,10 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- ) { cc/<= [ label JG ] } } case ; -: gc-root-offsets ( seq -- seq' ) +M: x86 gc-root-offsets [ n>> spill-offset special-offset cell + cell /i ] map f like ; -M: x86 %gc-map ( scrub-d scrub-r gc-roots -- ) - gc-root-offsets 3array set-next-gc-map ; - -M: x86 %call-gc +M: x86 %call-gc ( gc-map -- ) \ minor-gc %call gc-map-here ; @@ -612,8 +609,8 @@ M:: x86 %load-stack-param ( dst n rep -- ) M:: x86 %local-allot ( dst size align offset -- ) dst offset local-allot-offset special-offset stack@ LEA ; -M: x86 %alien-indirect ( src -- ) - ?spill-slot CALL ; +M: x86 %alien-indirect ( src gc-map -- ) + [ ?spill-slot CALL ] [ gc-map-here ] bi* ; M: x86 %loop-entry 16 alignment [ NOP ] times ; diff --git a/vm/collector.hpp b/vm/collector.hpp index 400e15b974..4a9eec5967 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -43,6 +43,8 @@ template struct gc_workhorse : no_fi object *fixup_data(object *obj) { + parent->check_data_pointer(obj); + if(!policy.should_copy_p(obj)) { policy.visited_object(obj); diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 6247b879c6..8ec3363662 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -65,7 +65,12 @@ void context::scrub_stacks(gc_info *info, cell index) for(cell loc = 0; loc < info->scrub_d_count; loc++) { if(bitmap_p(bitmap,base + loc)) + { +#ifdef DEBUG_GC_MAPS + std::cout << "scrubbing datastack location " << loc << std::endl; +#endif ((cell *)datastack)[-loc] = 0; + } } } @@ -75,7 +80,12 @@ void context::scrub_stacks(gc_info *info, cell index) for(cell loc = 0; loc < info->scrub_r_count; loc++) { if(bitmap_p(bitmap,base + loc)) + { +#ifdef DEBUG_GC_MAPS + std::cout << "scrubbing retainstack location " << loc << std::endl; +#endif ((cell *)retainstack)[-loc] = 0; + } } } } diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp index ba78b4b76c..4223f94a57 100644 --- a/vm/slot_visitor.hpp +++ b/vm/slot_visitor.hpp @@ -296,6 +296,9 @@ struct call_frame_slot_visitor { if(index == -1) return; +#ifdef DEBUG_GC_MAPS + std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl; +#endif u8 *bitmap = info->gc_info_bitmap(); cell base = info->spill_slot_base(index); cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1); @@ -303,7 +306,12 @@ struct call_frame_slot_visitor { for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++) { if(bitmap_p(bitmap,base + spill_slot)) + { +#ifdef DEBUG_GC_MAPS + std::cout << "visiting spill slot " << spill_slot << std::endl; +#endif visitor->visit_handle(&stack_pointer[spill_slot]); + } } } }; From 577e1175f3546c6a658836a9fb4c21f882c51cbc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Jun 2010 13:40:40 -0700 Subject: [PATCH 12/20] opengl.glu: add DESTRUCTOR: and CALLBACK: definitions for GLU tessellator --- extra/opengl/glu/glu.factor | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/extra/opengl/glu/glu.factor b/extra/opengl/glu/glu.factor index 856740d229..678e780e60 100644 --- a/extra/opengl/glu/glu.factor +++ b/extra/opengl/glu/glu.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.libraries alien.syntax kernel -sequences words system combinators opengl.gl ; +sequences words system combinators opengl.gl alien.destructors ; IN: opengl.glu << @@ -267,5 +267,21 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo ! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ; ! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ; +DESTRUCTOR: gluDeleteNurbsRenderer +DESTRUCTOR: gluDeleteQuadric +DESTRUCTOR: gluDeleteTess + +CALLBACK: void GLUtessBeginCallback ( GLenum type ) ; +CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ; +CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ; +CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ; +CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ; +CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ; +CALLBACK: void GLUtessEndCallback ( ) ; +CALLBACK: void GLUtessEndDataCallback ( void* data ) ; +CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ; +CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ; +CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ; + : gl-look-at ( eye focus up -- ) [ first3 ] tri@ gluLookAt ; From 5d6816d364eaa9136b9b9f4d857b5bbae7fde68d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Jun 2010 17:17:37 -0400 Subject: [PATCH 13/20] compiler.cfg.ssa: fixing test failures --- basis/compiler/cfg/gc-checks/gc-checks-tests.factor | 10 ++++------ .../cfg/ssa/interference/interference-tests.factor | 2 +- .../stacks/uninitialized/uninitialized-tests.factor | 6 +++--- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index 698caa5e68..d8745c0784 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -42,13 +42,12 @@ V{ [ V{ - T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } } - T{ ##call-gc } + T{ ##call-gc f T{ gc-map } } T{ ##branch } } ] [ - V{ D 0 R 3 } { 0 1 2 } instructions>> + instructions>> ] unit-test 30 \ vreg-counter set-global @@ -82,7 +81,7 @@ V{ [ ] [ cfg get needs-predecessors drop ] unit-test -[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test +[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test [ t ] [ 1 get successors>> first gc-check? ] unit-test @@ -146,8 +145,7 @@ H{ [ V{ - T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } } - T{ ##call-gc } + T{ ##call-gc f T{ gc-map } } T{ ##branch } } ] [ 2 get predecessors>> second instructions>> ] unit-test diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor index 4e3da1c6dc..36c03bc6af 100644 --- a/basis/compiler/cfg/ssa/interference/interference-tests.factor +++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor @@ -182,7 +182,7 @@ V{ V{ T{ ##save-context f 77 78 } - T{ ##call-gc f { } } + T{ ##call-gc f T{ gc-map } } T{ ##branch } } 2 test-bb diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor index 61c3cd67d1..fb9c833136 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor @@ -29,8 +29,8 @@ V{ [ ] [ test-uninitialized ] unit-test -[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test -[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test +[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test +[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test ! When merging, if a location is uninitialized in one branch and ! initialized in another, we have to consider it uninitialized, @@ -57,4 +57,4 @@ V{ [ ] [ test-uninitialized ] unit-test -[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test +[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test From 34d261a9e1e7a7cd3acf4ce5a5574b0016b46fe8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Jun 2010 18:32:13 -0400 Subject: [PATCH 14/20] pop3: fix tests to not hang if openssl is not installed --- extra/pop3/pop3-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/pop3/pop3-tests.factor b/extra/pop3/pop3-tests.factor index 8efc07ceee..10c5024d58 100644 --- a/extra/pop3/pop3-tests.factor +++ b/extra/pop3/pop3-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Elie Chaftari. ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises namespaces kernel pop3 pop3.server -sequences tools.test accessors ; +sequences tools.test accessors calendar ; IN: pop3.tests FROM: pop3 => count delete ; @@ -12,7 +12,7 @@ FROM: pop3 => count delete ; [ ] [ "127.0.0.1" >>host - "p1" get ?promise >>port + "p1" get 5 seconds ?promise-timeout >>port connect ] unit-test [ ] [ "username@host.com" >user ] unit-test @@ -59,7 +59,7 @@ FROM: pop3 => count delete ; [ ] [ "127.0.0.1" >>host - "p2" get ?promise >>port + "p2" get 5 seconds ?promise-timeout >>port "username@host.com" >>user "password" >>pwd connect From f3f5bbfb5806f1c8b3011c7e97538ad57b4ea5ee Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Jun 2010 15:31:19 -0700 Subject: [PATCH 15/20] new vocab alien.handles: generate integer handles to allow references to Factor objects to be passed through the FFI --- extra/alien/handles/authors.txt | 1 + extra/alien/handles/handles-tests.factor | 45 ++++++++++++++++++++++ extra/alien/handles/handles.factor | 49 ++++++++++++++++++++++++ extra/alien/handles/summary.txt | 1 + 4 files changed, 96 insertions(+) create mode 100644 extra/alien/handles/authors.txt create mode 100644 extra/alien/handles/handles-tests.factor create mode 100644 extra/alien/handles/handles.factor create mode 100644 extra/alien/handles/summary.txt diff --git a/extra/alien/handles/authors.txt b/extra/alien/handles/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/alien/handles/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/alien/handles/handles-tests.factor b/extra/alien/handles/handles-tests.factor new file mode 100644 index 0000000000..38ce7c26c7 --- /dev/null +++ b/extra/alien/handles/handles-tests.factor @@ -0,0 +1,45 @@ +! (c)2010 Joe Groff bsd license +USING: accessors alien alien.c-types alien.handles alien.syntax +destructors kernel math tools.test ; +IN: alien.handles.tests + +TUPLE: thingy { x integer } ; +C: thingy + +CALLBACK: int thingy-callback ( uint thingy-handle ) ; +CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ; + +: test-thingy-callback ( -- alien ) + [ alien-handle> x>> 1 + ] thingy-callback ; + +: test-thingy-ptr-callback ( -- alien ) + [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ; + +: invoke-test-thingy-callback ( thingy -- n ) + test-thingy-callback int { uint } cdecl alien-indirect ; +: invoke-test-thingy-ptr-callback ( thingy -- n ) + test-thingy-ptr-callback int { void* } cdecl alien-indirect ; + +[ t f ] [ + [ 5 &release-alien-handle [ alien-handle? ] keep ] with-destructors + alien-handle? +] unit-test + +[ t f ] [ + [ 5 &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors + alien-handle-ptr? +] unit-test + +[ 6 ] [ + [ + 5 &release-alien-handle + invoke-test-thingy-callback + ] with-destructors +] unit-test + +[ 6 ] [ + [ + 5 &release-alien-handle-ptr + invoke-test-thingy-ptr-callback + ] with-destructors +] unit-test diff --git a/extra/alien/handles/handles.factor b/extra/alien/handles/handles.factor new file mode 100644 index 0000000000..e1b5a716d2 --- /dev/null +++ b/extra/alien/handles/handles.factor @@ -0,0 +1,49 @@ +! (c)2010 Joe Groff bsd license +USING: alien alien.destructors assocs kernel math math.bitwise +namespaces ; +IN: alien.handles + + + +: ( object -- int ) + next-handle [ alien-handles get-global set-at ] keep ; inline +: alien-handle> ( int -- object ) + alien-handles get-global at ; inline + +: alien-handle? ( int -- ? ) + alien-handles get-global key? >boolean ; inline + +: release-alien-handle ( int -- ) + alien-handles get-global delete-at ; inline + +DESTRUCTOR: release-alien-handle + +: ( object -- void* ) + ; inline +: alien-handle-ptr> ( void* -- object ) + alien-address alien-handle> ; inline + +: alien-handle-ptr? ( alien -- ? ) + alien-address alien-handle? ; inline + +: release-alien-handle-ptr ( alien -- ) + alien-address release-alien-handle ; inline + +DESTRUCTOR: release-alien-handle-ptr + diff --git a/extra/alien/handles/summary.txt b/extra/alien/handles/summary.txt new file mode 100644 index 0000000000..17c2a240cd --- /dev/null +++ b/extra/alien/handles/summary.txt @@ -0,0 +1 @@ +Generate integer handle values to allow Factor object references to be passed through the FFI From e10d4f39ee7f2f8f9ffb2f7d67674041f11c7474 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Jun 2010 21:55:26 -0700 Subject: [PATCH 16/20] math.vectors.simd.cords: use head-slice/tail-slice to slice up input sequences for >A op so that e.g. float-4{ ... } >double-4 works --- basis/math/vectors/simd/cords/cords.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/vectors/simd/cords/cords.factor b/basis/math/vectors/simd/cords/cords.factor index 4d98af538f..cc3aa023e7 100644 --- a/basis/math/vectors/simd/cords/cords.factor +++ b/basis/math/vectors/simd/cords/cords.factor @@ -28,8 +28,8 @@ BOA-EFFECT [ N 2 * "n" { "v" } ] WHERE : >A ( seq -- A ) - [ N head >A/2 ] - [ N tail >A/2 ] bi cord-append ; + [ N head-slice >A/2 ] + [ N tail-slice >A/2 ] bi cord-append ; \ A-boa { N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation From 15c63aacb972cd0c75a326632351e2db76e83927 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Jun 2010 22:44:15 -0700 Subject: [PATCH 17/20] math.vectors.simd.cords: add regression test for >A --- basis/math/vectors/simd/cords/cords-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 basis/math/vectors/simd/cords/cords-tests.factor diff --git a/basis/math/vectors/simd/cords/cords-tests.factor b/basis/math/vectors/simd/cords/cords-tests.factor new file mode 100644 index 0000000000..eee11b396a --- /dev/null +++ b/basis/math/vectors/simd/cords/cords-tests.factor @@ -0,0 +1,4 @@ +USING: math.vectors.simd math.vectors.simd.cords tools.test ; +IN: math.vectors.simd.cords.tests + +[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test From 05dff4425ccac401b3892ece9dddaeba1e23f89b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jun 2010 16:48:58 -0400 Subject: [PATCH 18/20] tools.disassembler.udis: update struct layout for latest udis from git --- basis/tools/disassembler/udis/udis-tests.factor | 5 ++--- basis/tools/disassembler/udis/udis.factor | 6 +++++- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor index df3ef41365..522893f368 100644 --- a/basis/tools/disassembler/udis/udis-tests.factor +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -2,8 +2,7 @@ IN: tools.disassembler.udis.tests USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; { - { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] } - { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] } - { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] } + { [ cpu x86.32? ] [ [ 604 ] [ ud heap-size ] unit-test ] } + { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] } [ ] } cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index e998a5cfdb..8cf885f583 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -67,7 +67,11 @@ STRUCT: ud { c3 uchar } { inp_cache uchar[256] } { inp_sess uchar[64] } - { itab_entry void* } ; + { have_modrm uchar } + { modrm uchar } + { user_opaque_data void* } + { itab_entry void* } + { le void* } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; From c746b68c284d87c4afa7758922857f33953616a6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 25 Oct 2009 11:41:44 +0100 Subject: [PATCH 19/20] added doc for with-local-address --- basis/io/sockets/sockets-docs.factor | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index a41fc1e6c3..d0977dd3d0 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -34,6 +34,10 @@ ARTICLE: "network-connection" "Connection-oriented networking" with-client } +"The local address of a client socket can be controlled with this word:" +{ $subsections + with-local-address +} "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:" { $subsections @@ -215,3 +219,17 @@ HELP: send HELP: resolve-host { $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } } { $description "Resolves host names to IP addresses." } ; + +HELP: with-local-address +{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } } +{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." } +{ $examples + { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1." + "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." } + { $code "\"127.0.0.1\" 0 [ ] with-local-address" } + $nl + { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. " + "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown." + } + { $code "\"192.168.0.1\" 23000 [ ] with-local-address" } +} ; From f29a1038eb4ca1a3a1c634082bef34eae463a314 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 16 Jun 2010 19:08:58 -0400 Subject: [PATCH 20/20] vm: improved fingering technique --- vm/free_list_allocator.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/free_list_allocator.hpp b/vm/free_list_allocator.hpp index 7d7807ef9a..8c63bd487d 100644 --- a/vm/free_list_allocator.hpp +++ b/vm/free_list_allocator.hpp @@ -164,7 +164,7 @@ template struct heap_compactor { { if(this->state->marked_p(block)) { - *finger = block; + *finger = (Block *)((char *)block + size); memmove((Block *)address,block,size); iter(block,(Block *)address,size); address += size;