PowerPC support work in progress

core/compiler/compiler.factor

@@ -57,7 +57,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
     ] computing-dependencies ;
 
 : compile-failed ( word error -- )
-    dup inference-error? [ rethrow ] unless
+    ! dup inference-error? [ rethrow ] unless
     f pick compiled get set-at
     swap compiler-error ;
 

core/compiler/errors/errors.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces assocs prettyprint io sequences
 sorting continuations debugger math ;
@@ -24,6 +24,8 @@ SYMBOL: with-compiler-errors?
 
 GENERIC: compiler-warning? ( error -- ? )
 
+M: object compiler-warning? drop f ;
+
 : (:errors) ( -- assoc )
     compiler-errors get-global
     [ nip compiler-warning? not ] assoc-subset ;

core/cpu/ppc/architecture/architecture.factor

@@ -3,7 +3,8 @@
 USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
-layouts classes words.private alien combinators ;
+layouts classes words.private alien combinators
+compiler.constants ;
 IN: cpu.ppc.architecture
 
 TUPLE: ppc-backend ;
@@ -37,7 +38,7 @@ TUPLE: ppc-backend ;
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size 4 cells ;
+: factor-area-size 2 cells ;
 
 : next-save ( n -- i ) cell - ;
 
@@ -77,7 +78,7 @@ M: ppc-backend load-indirect ( obj reg -- )
     dup 0 LWZ ;
 
 M: ppc-backend %save-word-xt ( -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
 
 M: ppc-backend %prologue ( n -- )
     0 MFLR
@@ -99,35 +100,15 @@ M: ppc-backend %epilogue ( n -- )
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
-M: ppc-backend %profiler-prologue ( word -- )
-    3 load-indirect
-    4 3 profile-count-offset LWZ
-    4 4 1 v>operand ADDI
-    4 3 profile-count-offset STW ;
-
 M: ppc-backend %call-label ( label -- ) BL ;
 
 M: ppc-backend %jump-label ( label -- ) B ;
 
-: %prepare-primitive ( word -- )
-    #! Save stack pointer to stack_chain->callstack_top, load XT
-    4 1 MR
-    0 11 LOAD32
-    rc-absolute-ppc-2/2 rel-word ;
-
-: (%call) 11 MTLR BLRL ;
-
-M: ppc-backend %call-primitive ( word -- )
-    %prepare-primitive (%call) ;
-
-: (%jump) 11 MTCTR BCTR ;
-
-M: ppc-backend %jump-primitive ( word -- )
-    %prepare-primitive (%jump) ;
-
 M: ppc-backend %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
+: (%call) 11 MTLR BLRL ;
+
 : dispatch-template ( word-table# quot -- )
     [
         >r
@@ -145,7 +126,7 @@ M: ppc-backend %call-dispatch ( word-table# -- )
     [ (%call) ] dispatch-template ;
 
 M: ppc-backend %jump-dispatch ( word-table# -- )
-    [ %epilogue-later (%jump) ] dispatch-template ;
+    [ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
 
 M: ppc-backend %return ( -- ) %epilogue-later BLR ;
 

core/cpu/ppc/bootstrap.factor

@@ -29,7 +29,7 @@ big-endian on
     temp-reg dup 0 LWZ
     ! Bump profiling counter
     aux-reg temp-reg profile-count-offset LWZ
-    aux-reg dup 1 tag-fixnum ADD
+    aux-reg dup 1 tag-fixnum ADDI
     aux-reg temp-reg profile-count-offset STW
     ! Load word->code
     aux-reg temp-reg word-code-offset LWZ

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
 sbufs vectors system layouts math.floats.private
 classes tuples tuples.private sbufs.private vectors.private
 strings.private slots.private combinators bit-arrays
-float-arrays ;
+float-arrays compiler.constants ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag

core/cpu/ppc/ppc.factor

@@ -13,5 +13,3 @@ namespaces alien.c-types kernel system combinators ;
 } cond
 
 T{ ppc-backend } compiler-backend set-global
-
-6 cells profiler-prologue set-global

vm/callstack.c

@@ -216,8 +216,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	REGISTER_UNTAGGED(callstack);
 	REGISTER_UNTAGGED(quot);
 
-	if(quot->compiledp == F)
+	jit_compile(tag_object(quot),true);
-		jit_compile(tag_object(quot));
 
 	UNREGISTER_UNTAGGED(quot);
 	UNREGISTER_UNTAGGED(callstack);

vm/code_heap.c

@@ -303,10 +303,10 @@ void set_word_code(F_WORD *word, F_COMPILED *compiled)
 }
 
 /* Allocates memory */
-void default_word_code(F_WORD *word)
+void default_word_code(F_WORD *word, bool relocate)
 {
 	REGISTER_UNTAGGED(word);
-	jit_compile(word->def);
+	jit_compile(word->def,relocate);
 	UNREGISTER_UNTAGGED(word);
 
 	word->code = untag_quotation(word->def)->code;
@@ -336,7 +336,7 @@ DEFINE_PRIMITIVE(modify_code_heap)
 		{
 			REGISTER_UNTAGGED(alist);
 			REGISTER_UNTAGGED(word);
-			default_word_code(word);
+			default_word_code(word,false);
 			UNREGISTER_UNTAGGED(word);
 			UNREGISTER_UNTAGGED(alist);
 		}

vm/code_heap.h

@@ -56,7 +56,7 @@ typedef struct {
 void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
 
-void default_word_code(F_WORD *word);
+void default_word_code(F_WORD *word, bool relocate);
 
 void set_word_code(F_WORD *word, F_COMPILED *compiled);
 

vm/factor.c

@@ -44,7 +44,7 @@ void do_stage1_init(void)
 		if(type_of(obj) == WORD_TYPE)
 		{
 			F_WORD *word = untag_object(obj);
-			default_word_code(word);
+			default_word_code(word,false);
 			update_word_xt(word);
 		}
 	}

vm/profiler.c

@@ -13,7 +13,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
 
 	CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
 		| (to_fixnum(array_nth(quadruple,1)) << 8));
-	CELL rel_offset = array_nth(quadruple,3);
+	CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
 
 	CELL relocation = allot_array_2(rel_type,rel_offset);
 

vm/quotations.c

@@ -52,7 +52,7 @@ F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
 		rel.type = to_fixnum(rel_type)
 			| (to_fixnum(rel_class) << 8)
 			| (rel_argument << 16);
-		rel.offset = code_length * code_format + to_fixnum(offset);
+		rel.offset = (code_length + to_fixnum(offset)) * code_format;
 	}
 
 	return rel;
@@ -95,7 +95,7 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
 }
 
 /* Might GC */
-void jit_compile(CELL quot)
+void jit_compile(CELL quot, bool relocate)
 {
 	if(untag_quotation(quot)->compiledp != F)
 		return;
@@ -230,10 +230,9 @@ void jit_compile(CELL quot)
 		untag_object(words),
 		untag_object(literals));
 
-	/* We must do this before relocate_code_block(), so that
-	relocation knows the quotation's XT. */
 	set_quot_xt(untag_object(quot),compiled);
 
+	if(relocate)
 		iterate_code_heap_step(compiled,relocate_code_block);
 
 	UNREGISTER_ROOT(words);
@@ -352,7 +351,7 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 {
 	stack_chain->callstack_top = stack;
 	REGISTER_ROOT(quot);
-	jit_compile(quot);
+	jit_compile(quot,true);
 	UNREGISTER_ROOT(quot);
 	return quot;
 }

vm/quotations.h

@@ -1,5 +1,5 @@
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
-void jit_compile(CELL quot);
+void jit_compile(CELL quot, bool relocate);
 F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
 F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
 void uncurry(CELL obj);

vm/types.c

@@ -511,7 +511,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
 	word->profiling = NULL;
 
 	REGISTER_UNTAGGED(word);
-	default_word_code(word);
+	default_word_code(word,true);
 	UNREGISTER_UNTAGGED(word);
 
 	REGISTER_UNTAGGED(word);