basis/compiler/codegen/fixup/fixup.factor

   1 ! Copyright (C) 2007, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays byte-arrays byte-vectors generic assocs hashtables
   4 io.binary kernel kernel.private math namespaces make sequences
   5 words quotations strings alien.accessors alien.strings layouts
   6 system combinators math.bitwise words.private math.order
   7 accessors growable cpu.architecture compiler.constants ;
   8 IN: compiler.codegen.fixup
   9
  10 GENERIC: fixup* ( obj -- )
  11
  12 : code-format ( -- n ) 22 getenv ;
  13
  14 : compiled-offset ( -- n ) building get length code-format * ;
  15
  16 SYMBOL: relocation-table
  17 SYMBOL: label-table
  18
  19 M: label fixup* compiled-offset >>offset drop ;
  20
  21 TUPLE: label-fixup label class ;
  22
  23 : label-fixup ( label class -- ) \ label-fixup boa , ;
  24
  25 M: label-fixup fixup*
  26     dup class>> rc-absolute?
  27     [ "Absolute labels not supported" throw ] when
  28     [ label>> ] [ class>> ] bi compiled-offset 4 - rot
  29     3array label-table get push ;
  30
  31 TUPLE: rel-fixup arg class type ;
  32
  33 : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
  34
  35 : push-4 ( value vector -- )
  36     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  37     swap set-alien-unsigned-4 ;
  38
  39 M: rel-fixup fixup*
  40     [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
  41     [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
  42     [ relocation-table get push-4 ] bi@ ;
  43
  44 M: integer fixup* , ;
  45
  46 : indq ( elt seq -- n ) [ eq? ] with find drop ;
  47
  48 : adjoin* ( obj table -- n )
  49     2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
  50
  51 SYMBOL: literal-table
  52
  53 : add-literal ( obj -- n ) literal-table get adjoin* ;
  54
  55 : add-dlsym-literals ( symbol dll -- )
  56     [ string>symbol ] dip 2array literal-table get push-all ;
  57
  58 : rel-dlsym ( name dll class -- )
  59     [ literal-table get length [ add-dlsym-literals ] dip ] dip
  60     rt-dlsym rel-fixup ;
  61
  62 : rel-word ( word class -- )
  63     [ add-literal ] dip rt-xt rel-fixup ;
  64
  65 : rel-primitive ( word class -- )
  66     [ def>> first ] dip rt-primitive rel-fixup ;
  67
  68 : rel-immediate ( literal class -- )
  69     [ add-literal ] dip rt-immediate rel-fixup ;
  70
  71 : rel-this ( class -- )
  72     0 swap rt-label rel-fixup ;
  73
  74 : rel-here ( offset class -- )
  75     rt-here rel-fixup ;
  76
  77 : init-fixup ( -- )
  78     BV{ } clone relocation-table set
  79     V{ } clone label-table set ;
  80
  81 : resolve-labels ( labels -- labels' )
  82     [
  83         first3 offset>>
  84         [ "Unresolved label" throw ] unless*
  85         3array
  86     ] map concat ;
  87
  88 : fixup ( fixup-directives -- code )
  89     [
  90         init-fixup
  91         [ fixup* ] each
  92         literal-table get >array
  93         relocation-table get >byte-array
  94         label-table get resolve-labels
  95     ] { } make 4array ;