basis/compiler/codegen/fixup/fixup.factor

   1 ! Copyright (C) 2007, 2010 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 math.order combinators.smart
   7 accessors growable fry compiler.constants memoize ;
   8 IN: compiler.codegen.fixup
   9
  10 ! Utilities
  11 : push-uint ( value vector -- )
  12     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  13     swap set-alien-unsigned-4 ;
  14
  15 ! Parameter table
  16 SYMBOL: parameter-table
  17
  18 : add-parameter ( obj -- ) parameter-table get push ;
  19
  20 ! Literal table
  21 SYMBOL: literal-table
  22
  23 : add-literal ( obj -- ) literal-table get push ;
  24
  25 ! Labels
  26 SYMBOL: label-table
  27
  28 TUPLE: label offset ;
  29
  30 : <label> ( -- label ) label new ;
  31 : define-label ( name -- ) <label> swap set ;
  32
  33 : compiled-offset ( -- n ) building get length ;
  34
  35 : resolve-label ( label/name -- )
  36     dup label? [ get ] unless
  37     compiled-offset >>offset drop ;
  38
  39 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
  40
  41 : label-fixup ( label class -- )
  42     compiled-offset \ label-fixup boa label-table get push ;
  43
  44 ! Relocation table
  45 SYMBOL: relocation-table
  46
  47 : add-relocation-entry ( type class offset -- )
  48     { 0 24 28 } bitfield relocation-table get push-uint ;
  49
  50 : rel-fixup ( class type -- )
  51     swap compiled-offset add-relocation-entry ;
  52
  53 ! Binary literal table
  54 SYMBOL: binary-literal-table
  55
  56 : add-binary-literal ( obj -- label )
  57     <label> [ 2array binary-literal-table get push ] keep ;
  58
  59 ! Caching common symbol names reduces image size a bit
  60 MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
  61
  62 : add-dlsym-parameters ( symbol dll -- )
  63     [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
  64
  65 : rel-dlsym ( name dll class -- )
  66     [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
  67
  68 : rel-word ( word class -- )
  69     [ add-literal ] dip rt-entry-point rel-fixup ;
  70
  71 : rel-word-pic ( word class -- )
  72     [ add-literal ] dip rt-entry-point-pic rel-fixup ;
  73
  74 : rel-word-pic-tail ( word class -- )
  75     [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
  76
  77 : rel-literal ( literal class -- )
  78     [ add-literal ] dip rt-literal rel-fixup ;
  79
  80 : rel-binary-literal ( literal class -- )
  81     [ add-binary-literal ] dip label-fixup ;
  82
  83 : rel-this ( class -- )
  84     rt-this rel-fixup ;
  85
  86 : rel-here ( offset class -- )
  87     [ add-literal ] dip rt-here rel-fixup ;
  88
  89 : rel-vm ( offset class -- )
  90     [ add-parameter ] dip rt-vm rel-fixup ;
  91
  92 : rel-cards-offset ( class -- )
  93     rt-cards-offset rel-fixup ;
  94
  95 : rel-decks-offset ( class -- )
  96     rt-decks-offset rel-fixup ;
  97
  98 ! And the rest
  99 : compute-target ( label-fixup -- offset )
 100     label>> offset>> [ "Unresolved label" throw ] unless* ;
 101
 102 : compute-relative-label ( label-fixup -- label )
 103     [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
 104
 105 : compute-absolute-label ( label-fixup -- )
 106     [ compute-target neg add-literal ]
 107     [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
 108
 109 : compute-labels ( label-fixups -- labels' )
 110     [ class>> rc-absolute? ] partition
 111     [ [ compute-absolute-label ] each ]
 112     [ [ compute-relative-label ] map concat ]
 113     bi* ;
 114
 115 : init-fixup ( -- )
 116     V{ } clone parameter-table set
 117     V{ } clone literal-table set
 118     V{ } clone label-table set
 119     BV{ } clone relocation-table set
 120     V{ } clone binary-literal-table set ;
 121
 122 : alignment ( align -- n )
 123     [ compiled-offset dup ] dip align swap - ;
 124
 125 : (align-code) ( n -- )
 126     0 <repetition> % ;
 127
 128 : align-code ( n -- )
 129     alignment (align-code) ;
 130
 131 : emit-data ( obj label -- )
 132     over length align-code
 133     resolve-label
 134     building get push-all ;
 135
 136 : emit-binary-literals ( -- )
 137     binary-literal-table get [ emit-data ] assoc-each ;
 138
 139 : with-fixup ( quot -- code )
 140     '[
 141         [
 142             init-fixup
 143             @
 144             emit-binary-literals
 145             label-table [ compute-labels ] change
 146             parameter-table get >array
 147             literal-table get >array
 148             relocation-table get >byte-array
 149             label-table get
 150         ] B{ } make
 151     ] output>array ; inline