Merge branch 'master' of git://factorcode.org/git/factor

core/bootstrap/compiler/compiler.factor

@@ -4,15 +4,17 @@ USING: compiler cpu.architecture vocabs.loader system sequences
 namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors tuples sbufs inference.dataflow
 hashtables.private sequences.private math tuples.private
-growable namespaces.private alien.remote-control assocs words
+growable namespaces.private assocs words generator command-line
-generator command-line vocabs io prettyprint libc definitions ;
+vocabs io prettyprint libc definitions ;
 IN: bootstrap.compiler
 
-"cpu." cpu append require
+! Don't bring this in when deploying, since it will store a
+! reference to 'eval' in a global variable
+"deploy-vocab" get [
+    "alien.remote-control" require
+] unless
 
-"-no-stack-traces" cli-args member? [
+"cpu." cpu append require
-    f compiled-stack-traces? set-global
-] when
 
 nl
 "Compiling some words to speed up bootstrap..." write

core/bootstrap/stage2.factor

@@ -45,7 +45,7 @@ IN: bootstrap.stage2
 
         run-bootstrap-init
 
-        "Compiling remaining words..." print
+        "Compiling remaining words..." print flush
 
         all-words [ compiled? not ] subset recompile-hook get call
     ] with-compiler-errors

core/cpu/x86/architecture/architecture.factor

@@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
 M: x86-backend %save-word-xt ( -- )
-    xt-reg 0 MOV rc-absolute-cell rel-current-word ;
+    xt-reg 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 

core/cpu/x86/bootstrap.factor

@@ -28,7 +28,7 @@ big-endian off
     stack-frame-size PUSH                      ! save stack frame size
     0 PUSH                                     ! push XT
     arg1 PUSH                                  ! alignment
-] rc-absolute-cell rt-xt 6 jit-prolog jit-define
+] rc-absolute-cell rt-label 6 jit-prolog jit-define
 
 [
     arg0 0 [] MOV                              ! load literal

core/generator/fixup/fixup.factor

@@ -64,13 +64,12 @@ SYMBOL: label-table
     rot rc-absolute-ppc-2/2 = or or ;
 
 ! Relocation types
-: rt-primitive    0 ;
+: rt-primitive 0 ;
-: rt-dlsym        1 ;
+: rt-dlsym     1 ;
-: rt-literal      2 ;
+: rt-literal   2 ;
-: rt-dispatch     3 ;
+: rt-dispatch  3 ;
-: rt-xt           4 ;
+: rt-xt        4 ;
-: rt-xt-profiling 5 ;
+: rt-label     6 ;
-: rt-label        6 ;
 
 TUPLE: label-fixup label class ;
 
@@ -133,6 +132,9 @@ SYMBOL: word-table
 : rel-literal ( literal class -- )
     >r add-literal r> rt-literal rel-fixup ;
 
+: rel-this ( class -- )
+    0 swap rt-label rel-fixup ;
+
 : init-fixup ( -- )
     V{ } clone relocation-table set
     V{ } clone label-table set ;

core/generator/generator-docs.factor

@@ -28,7 +28,8 @@ HELP: compiling-label
 { $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
 
 HELP: compiled-stack-traces?
-{ $var-description "If set to true, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This variable is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
+{ $values { "?" "a boolean" } }
+{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
 HELP: literal-table
 { $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;

core/generator/generator.factor

@@ -36,14 +36,12 @@ SYMBOL: compiling-label
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
-SYMBOL: compiled-stack-traces?
+: compiled-stack-traces? ( -- ? ) 36 getenv ;
-
-t compiled-stack-traces? set-global
 
 : init-generator ( compiling -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces? get swap f ?
+    compiled-stack-traces? swap f ?
     literal-table get push ;
 
 : generate-1 ( word label node quot -- )
@@ -153,10 +151,6 @@ M: #if generate-node
     with-template
     generate-if ;
 
-: rel-current-word ( class -- )
-    compiling-label get add-word
-    swap rt-xt-profiling rel-fixup ;
-
 ! #dispatch
 : dispatch-branch ( node word -- label )
     gensym [

extra/new-slots/new-slots.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: effects words kernel sequences slots slots.private
+assocs parser mirrors ;
+IN: new-slots
+
+: reader-effect T{ effect f 1 1 } ; inline
+
+: writer-effect T{ effect f 2 0 } ; inline
+
+: create-accessor ( name effect -- word )
+    >r "accessors" create dup r>
+    "declared-effect" set-word-prop ;
+
+: reader-word ( name -- word )
+    ">>" append reader-effect create-accessor ;
+
+: writer-word ( name -- word )
+    ">>" swap append writer-effect create-accessor ;
+
+: define-reader ( class slot name -- )
+    reader-word [ slot ] define-slot-word ;
+
+: define-writer ( class slot name -- )
+    writer-word [ set-slot ] define-slot-word ;
+
+: define-new-slots ( tuple-class -- )
+    [ "slot-names" word-prop <enum> >alist ] keep
+    [
+        swap first2 >r 2 + r> 3dup define-reader define-writer
+    ] curry each ;
+
+: NEW-SLOTS: scan-word define-new-slots ; parsing

extra/tools/deploy/shaker/shaker.factor

@@ -48,8 +48,8 @@ IN: tools.deploy.shaker
     [ f over set-word-name f swap set-word-vocabulary ] each ;
 
 : strip-word-defs ( words -- )
-    "Stripping unoptimized definitions from optimized words" show
+    "Stripping symbolic word definitions" show
-    [ compiled? ] subset [ [ ] swap set-word-def ] each ;
+    [ [ ] swap set-word-def ] each ;
 
 : strip-word-props ( retain-props words -- )
     "Stripping word properties" show
@@ -109,10 +109,6 @@ SYMBOL: deploy-vocab
         builtins ,
         strip-io? [ io-backend , ] unless
 
-        deploy-compiler? get [
-            "callbacks" "alien.compiler" lookup ,
-        ] when
-
         strip-dictionary? [
             {
                 dictionary
@@ -154,11 +150,14 @@ SYMBOL: deploy-vocab
         ] when
     ] { } make dup . ;
 
-: strip ( hook -- )
+: strip-recompile-hook ( -- )
-    >r strip-libc
+    [ [ f ] { } map>assoc ] recompile-hook set-global ;
+
+: strip ( -- )
+    strip-libc
     strip-cocoa
     strip-debugger
-    r> [ call ] when*
+    strip-recompile-hook
     strip-init-hooks
     deploy-vocab get vocab-main set-boot-quot*
     retained-props >r
@@ -171,8 +170,6 @@ SYMBOL: deploy-vocab
     [
         [
             deploy-vocab set
-            parse-hook get
-            parse-hook off
             deploy-vocab get require
             strip
             finish-deploy

extra/tools/deploy/windows/windows.factor

@@ -37,8 +37,8 @@ M: windows-deploy-implementation deploy*
     stage1
     "." resource-path cd
     dup deploy-config [
-        [
+        [ deploy-name get create-exe-dir ] keep
-            [ deploy-name get create-exe-dir ] keep
+        [ deploy-name get image-name ] keep
-            [ deploy-name get image-name ] keep
+        [ namespace stage2 ] keep
-        ] bind
+        open-in-explorer
-    ] keep stage2 open-in-explorer ;
+    ] bind ;

vm/code_heap.c

@@ -40,10 +40,6 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
 INLINE CELL compute_code_rel(F_REL *rel,
 	CELL code_start, CELL literals_start, CELL words_start)
 {
-	CELL obj;
-	F_WORD *word;
-	F_QUOTATION *quot;
-
 	switch(REL_TYPE(rel))
 	{
 	case RT_PRIMITIVE:
@@ -55,22 +51,7 @@ INLINE CELL compute_code_rel(F_REL *rel,
 	case RT_DISPATCH:
 		return CREF(words_start,REL_ARGUMENT(rel));
 	case RT_XT:
-		obj = get(CREF(words_start,REL_ARGUMENT(rel)));
+		return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
-		switch(type_of(obj))
-		{
-		case WORD_TYPE:
-			word = untag_object(obj);
-			return (CELL)word->xt;
-		case QUOTATION_TYPE:
-			quot = untag_object(obj);
-			return (CELL)quot->xt;
-		default:
-			critical_error("Bad parameter to rt-xt relocation",obj);
-			return -1; /* Can't happen */
-		}
-	case RT_XT_PROFILING:
-		word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel))));
-		return (CELL)(word->code + 1);
 	case RT_LABEL:
 		return code_start + REL_ARGUMENT(rel);
 	default:
@@ -211,6 +192,11 @@ void deposit_objects(CELL here, F_ARRAY *array)
 	memcpy((void*)here,array + 1,array_capacity(array) * CELLS);
 }
 
+bool stack_traces_p(void)
+{
+	return to_boolean(userenv[STACK_TRACES_ENV]);
+}
+
 CELL compiled_code_format(void)
 {
 	return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
@@ -349,7 +335,9 @@ DEFINE_PRIMITIVE(modify_code_heap)
 		if(data == F)
 		{
 			REGISTER_UNTAGGED(alist);
+			REGISTER_UNTAGGED(word);
 			default_word_code(word);
+			UNREGISTER_UNTAGGED(word);
 			UNREGISTER_UNTAGGED(alist);
 		}
 		else

vm/code_heap.h

@@ -9,8 +9,8 @@ typedef enum {
 	RT_DISPATCH,
 	/* a compiled word reference */
 	RT_XT,
-	/* a compiled word reference, pointing at the profiling prologue */
+	/* reserved */
-	RT_XT_PROFILING,
+	RT_RESERVED,
 	/* a local label */
 	RT_LABEL
 } F_RELTYPE;
@@ -69,5 +69,6 @@ F_COMPILED *add_compiled_block(
 	F_ARRAY *literals);
 
 CELL compiled_code_format(void);
+bool stack_traces_p(void);
 
 DECLARE_PRIMITIVE(modify_code_heap);

vm/factor.c

@@ -27,6 +27,7 @@ void default_parameters(F_PARAMETERS *p)
 	p->secure_gc = false;
 	p->fep = false;
 	p->console = false;
+	p->stack_traces = true;
 }
 
 /* Do some initialization that we do once only */
@@ -96,6 +97,7 @@ void init_factor(F_PARAMETERS *p)
 	userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
 	userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
+	userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
 
 	/* We can GC now */
 	gc_off = false;
@@ -145,7 +147,9 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 		else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0)
 			p.image = argv[i] + 3;
 		else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
-			p.console = true ;
+			p.console = true;
+		else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0)
+			p.stack_traces = false;
 	}
 
 	init_factor(&p);

vm/image.h

@@ -33,6 +33,7 @@ typedef struct {
 	bool secure_gc;
 	bool fep;
 	bool console;
+	bool stack_traces;
 } F_PARAMETERS;
 
 void load_image(F_PARAMETERS *p);

vm/quotations.c

@@ -119,8 +119,7 @@ void jit_compile(CELL quot)
 	GROWABLE_ARRAY(words);
 	REGISTER_ROOT(words);
 
-	GROWABLE_ADD(literals,quot);
+	GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
-	GROWABLE_ADD(words,quot);
 
 	bool stack_frame = jit_stack_frame_p(untag_object(array));
 

vm/run.h

@@ -48,6 +48,8 @@ typedef enum {
 	JIT_RETURN,
 	JIT_PROFILING,
 
+	STACK_TRACES_ENV    = 36,
+
 	UNDEFINED_ENV       = 37, /* default quotation for undefined words */
 	STAGE2_ENV          = 39  /* have we bootstrapped? */
 } F_ENVTYPE;