More compact relocation layout

basis/compiler/codegen/codegen.factor

@@ -53,7 +53,7 @@ SYMBOL: labels
     V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
-    compiled-stack-traces? compiling-word get f ? add-literal drop ;
+    compiled-stack-traces? compiling-word get f ? add-literal ;
 
 : generate ( mr -- asm )
     [

basis/compiler/codegen/fixup/fixup.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
@@ -28,51 +28,47 @@ M: label-fixup fixup*
     [ label>> ] [ class>> ] bi compiled-offset 4 - rot
     3array label-table get push ;
 
-TUPLE: rel-fixup arg class type ;
+TUPLE: rel-fixup class type ;
 
-: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
+: rel-fixup ( class type -- ) \ rel-fixup boa , ;
 
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
 M: rel-fixup fixup*
-    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+    [ type>> ]
-    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+    [ class>> ]
-    [ relocation-table get push-4 ] bi@ ;
+    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
+    { 0 24 28 } bitfield
+    relocation-table get push-4 ;
 
 M: integer fixup* , ;
 
-: indq ( elt seq -- n ) [ eq? ] with find drop ;
-
-: adjoin* ( obj table -- n )
-    2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
-
 SYMBOL: literal-table
 
-: add-literal ( obj -- n ) literal-table get adjoin* ;
+: add-literal ( obj -- ) literal-table get push ;
 
 : add-dlsym-literals ( symbol dll -- )
-    [ string>symbol ] dip 2array literal-table get push-all ;
+    [ string>symbol add-literal ] [ add-literal ] bi* ;
 
 : rel-dlsym ( name dll class -- )
-    [ literal-table get length [ add-dlsym-literals ] dip ] dip
+    [ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
-    rt-dlsym rel-fixup ;
 
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
 : rel-primitive ( word class -- )
-    [ def>> first ] dip rt-primitive rel-fixup ;
+    [ def>> first add-literal ] dip rt-primitive rel-fixup ;
 
 : rel-immediate ( literal class -- )
     [ add-literal ] dip rt-immediate rel-fixup ;
 
 : rel-this ( class -- )
-    0 swap rt-label rel-fixup ;
+    rt-this rel-fixup ;
 
 : rel-here ( offset class -- )
-    rt-here rel-fixup ;
+    [ add-literal ] dip rt-here rel-fixup ;
 
 : init-fixup ( -- )
     BV{ } clone relocation-table set

basis/compiler/constants/constants.factor

@@ -23,7 +23,7 @@ CONSTANT: deck-bits 18
 : quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
 : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
 : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
+: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell    0
@@ -42,7 +42,7 @@ CONSTANT: rt-dlsym       1
 CONSTANT: rt-dispatch    2
 CONSTANT: rt-xt          3
 CONSTANT: rt-here        4
-CONSTANT: rt-label       5
+CONSTANT: rt-this        5
 CONSTANT: rt-immediate   6
 CONSTANT: rt-stack-chain 7
 

basis/cpu/ppc/bootstrap.factor

@@ -41,7 +41,7 @@ big-endian on
     stack-frame 6 LI
     6 1 next-save STW
     0 1 lr-save stack-frame + STW
-] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
+] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
 
 [
     0 6 LOAD32

basis/cpu/x86/bootstrap.factor

@@ -32,7 +32,7 @@ big-endian off
     temp0 PUSH
     ! alignment
     stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
+] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
 
 [
     ! load literal

basis/tools/profiler/profiler-tests.factor

@@ -25,7 +25,7 @@ words ;
 
 : indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
 
-: foobar ;
+: foobar ( -- ) ;
 
 [
     [ ] [ callback-test indirect-test ] unit-test
@@ -34,9 +34,9 @@ words ;
 
 [ 1 ] [ \ foobar counter>> ] unit-test
 
-: fooblah { } [ ] each ;
+: fooblah ( -- ) { } [ ] like call ;
 
-: foobaz fooblah fooblah ;
+: foobaz ( -- ) fooblah fooblah ;
 
 [ foobaz ] profile