load-locals is a primitive now, change semantics of get-locals to bum out 2 instructions from the sub-primitive

basis/cpu/ppc/bootstrap.factor

@@ -406,9 +406,7 @@ big-endian on
 [
     3 ds-reg 0 LWZ
     3 3 1 SRAWI
-    4 4 LI
-    4 3 4 SUBF
-    rs-reg 3 4 LWZX
+    rs-reg 3 3 LWZX
     3 ds-reg 0 STW
 ] f f f \ get-local define-sub-primitive
 

basis/cpu/x86/bootstrap.factor

@@ -382,9 +382,7 @@ big-endian off
 [
     arg0 ds-reg [] MOV                         ! load local number
     fixnum>slot@                               ! turn local number into offset
-    arg1 bootstrap-cell MOV                    ! load base
-    arg1 arg0 SUB                              ! turn it into a stack offset
-    arg0 rs-reg arg1 [+] MOV                   ! load local value
+    arg0 rs-reg arg0 [+] MOV                   ! load local value
     ds-reg [] arg0 MOV                         ! push to stack
 ] f f f \ get-local define-sub-primitive
 

basis/locals/backend/backend-tests.factor

@@ -1,39 +1,14 @@
 IN: locals.backend.tests
 USING: tools.test locals.backend kernel arrays ;
 
-[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
-
-[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
-
-: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
+: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
 
 \ get-local-test-1 must-infer
 
 [ 3 ] [ get-local-test-1 ] unit-test
 
-: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
+: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
 
 \ get-local-test-2 must-infer
 
-[ 4 ] [ get-local-test-2 ] unit-test
-
-: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
-
-\ get-local-test-3 must-infer
-
-[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
-
-: get-local-test-4 ( -- a b )
-    3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
-
-\ get-local-test-4 must-infer
-
-[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
-
-[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
-
-: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
-
-\ load-locals-test-1 must-infer
-
-[ 1 2 ] [ load-locals-test-1 ] unit-test
+[ 3 ] [ get-local-test-2 ] unit-test

basis/locals/backend/backend.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.private kernel slots.private sequences effects words ;
+USING: slots.private ;
 IN: locals.backend
 
-: load-locals ( n -- )
-    dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
-
 : local-value 2 slot ; inline
 
 : set-local-value 2 set-slot ; inline

basis/locals/locals.factor

@@ -103,7 +103,7 @@ C: <quote> quote
     [ dup quote? [ local>> ] when eq? ] with find drop ;
 
 : read-local-quot ( obj args -- quot )
-    local-index 1+ [ get-local ] curry ;
+    local-index neg [ get-local ] curry ;
 
 GENERIC# localize 1 ( obj args -- quot )
 
@@ -139,19 +139,17 @@ UNION: special local quote local-word local-reader local-writer ;
 : point-free-end ( quot args -- newquot )
     over peek special?
     [ dup drop-locals-quot [ [ peek ] dip localize ] dip append ]
-    [ dup drop-locals-quot nip swap peek suffix ]
+    [ drop-locals-quot swap peek suffix ]
     if ;
 
 : (point-free) ( quot args -- newquot )
     [ nip load-locals-quot ]
-    [ point-free-body ]
-    [ point-free-end ]
-    2tri 3append >quotation ;
+    [ reverse point-free-body ]
+    [ reverse point-free-end ]
+    2tri [ ] 3append-as ;
 
 : point-free ( quot args -- newquot )
-    over empty?
-    [ nip length \ drop <repetition> >quotation ]
-    [ (point-free) ] if ;
+    over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
 
 UNION: lexical local local-reader local-writer local-word ;
 

basis/stack-checker/known-words/known-words.factor

@@ -134,11 +134,11 @@ M: object infer-call*
 
 : infer-load-locals ( -- )
     pop-literal nip
-    consume-d dup reverse copy-values dup output-r
-    [ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
+    consume-d dup copy-values dup output-r
+    [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 
 : infer-get-local ( -- )
-    [let* | n [ pop-literal nip ]
+    [let* | n [ pop-literal nip 1 swap - ]
             in-r [ n consume-r ]
             out-d [ in-r first copy-value 1array ]
             out-r [ in-r copy-values ] |

core/bootstrap/primitives.factor

@@ -534,6 +534,7 @@ tuple
     { "unimplemented" "kernel.private" }
     { "gc-reset" "memory" }
     { "jit-compile" "quotations" }
+    { "load-locals" "locals.backend" }
 }
 [ [ first2 ] dip make-primitive ] each-index
 

vm/primitives.c

@@ -141,4 +141,5 @@ void *primitives[] = {
 	primitive_unimplemented,
 	primitive_gc_reset,
 	primitive_jit_compile,
+	primitive_load_locals,
 };

vm/run.c

@@ -190,3 +190,11 @@ void primitive_set_slot(void)
 	CELL value = dpop();
 	set_slot(obj,slot,value);
 }
+
+void primitive_load_locals(void)
+{
+	F_FIXNUM count = untag_fixnum_fast(dpop());
+	memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
+	ds -= CELLS * count;
+	rs += CELLS * count;
+}

vm/run.h

@@ -247,5 +247,6 @@ void primitive_set_os_envs(void);
 void primitive_micros(void);
 void primitive_sleep(void);
 void primitive_set_slot(void);
+void primitive_load_locals(void);
 
 bool stage2;

vm/types.c

@@ -331,15 +331,9 @@ void primitive_tuple_boa(void)
 {
 	F_TUPLE_LAYOUT *layout = untag_object(dpop());
 	F_FIXNUM size = untag_fixnum_fast(layout->size);
-
-	REGISTER_UNTAGGED(layout);
 	F_TUPLE *tuple = allot_tuple(layout);
-	UNREGISTER_UNTAGGED(layout);
-
-	F_FIXNUM i;
-	for(i = size - 1; i >= 0; i--)
-		put(AREF(tuple,i),dpop());
-
+	memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
+	ds -= CELLS * size;
 	dpush(tag_tuple(tuple));
 }