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 bit-arrays byte-arrays byte-vectors generic assocs
   4 hashtables io.binary kernel kernel.private math namespaces make
   5 sequences words quotations strings sorting alien.accessors
   6 alien.strings layouts system combinators math.bitwise math.order
   7 combinators.short-circuit combinators.smart accessors growable
   8 fry memoize compiler.constants compiler.cfg.instructions
   9 cpu.architecture ;
  10 IN: compiler.codegen.fixup
  11
  12 ! Utilities
  13 : push-uint ( value vector -- )
  14     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  15     swap set-alien-unsigned-4 ;
  16
  17 ! Parameter table
  18 SYMBOL: parameter-table
  19
  20 : add-parameter ( obj -- ) parameter-table get push ;
  21
  22 ! Literal table
  23 SYMBOL: literal-table
  24
  25 : add-literal ( obj -- ) literal-table get push ;
  26
  27 ! Labels
  28 SYMBOL: label-table
  29
  30 TUPLE: label offset ;
  31
  32 : <label> ( -- label ) label new ;
  33 : define-label ( name -- ) <label> swap set ;
  34
  35 : compiled-offset ( -- n ) building get length ;
  36
  37 : resolve-label ( label/name -- )
  38     dup label? [ get ] unless
  39     compiled-offset >>offset drop ;
  40
  41 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
  42
  43 : label-fixup ( label class -- )
  44     compiled-offset \ label-fixup boa label-table get push ;
  45
  46 ! Relocation table
  47 SYMBOL: relocation-table
  48
  49 : add-relocation-entry ( type class offset -- )
  50     { 0 24 28 } bitfield relocation-table get push-uint ;
  51
  52 : rel-fixup ( class type -- )
  53     swap compiled-offset add-relocation-entry ;
  54
  55 ! Binary literal table
  56 SYMBOL: binary-literal-table
  57
  58 : add-binary-literal ( obj -- label )
  59     <label> [ 2array binary-literal-table get push ] keep ;
  60
  61 ! Caching common symbol names reduces image size a bit
  62 MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
  63
  64 : add-dlsym-parameters ( symbol dll -- )
  65     [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
  66
  67 : rel-dlsym ( name dll class -- )
  68     [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
  69
  70 : rel-dlsym-toc ( name dll class -- )
  71     [ add-dlsym-parameters ] dip rt-dlsym-toc rel-fixup ;
  72
  73 : rel-word ( word class -- )
  74     [ add-literal ] dip rt-entry-point rel-fixup ;
  75
  76 : rel-word-pic ( word class -- )
  77     [ add-literal ] dip rt-entry-point-pic rel-fixup ;
  78
  79 : rel-word-pic-tail ( word class -- )
  80     [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
  81
  82 : rel-literal ( literal class -- )
  83     [ add-literal ] dip rt-literal rel-fixup ;
  84
  85 : rel-binary-literal ( literal class -- )
  86     [ add-binary-literal ] dip label-fixup ;
  87
  88 : rel-this ( class -- )
  89     rt-this rel-fixup ;
  90
  91 : rel-here ( offset class -- )
  92     [ add-literal ] dip rt-here rel-fixup ;
  93
  94 : rel-vm ( offset class -- )
  95     [ add-parameter ] dip rt-vm rel-fixup ;
  96
  97 : rel-cards-offset ( class -- )
  98     rt-cards-offset rel-fixup ;
  99
 100 : rel-decks-offset ( class -- )
 101     rt-decks-offset rel-fixup ;
 102
 103 ! Labels
 104 : compute-target ( label-fixup -- offset )
 105     label>> offset>> [ "Unresolved label" throw ] unless* ;
 106
 107 : compute-relative-label ( label-fixup -- label )
 108     [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
 109
 110 : compute-absolute-label ( label-fixup -- )
 111     [ compute-target neg add-literal ]
 112     [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
 113
 114 : compute-labels ( label-fixups -- labels' )
 115     [ class>> rc-absolute? ] partition
 116     [ [ compute-absolute-label ] each ]
 117     [ [ compute-relative-label ] map concat ]
 118     bi* ;
 119
 120 ! Binary literals
 121 : alignment ( align -- n )
 122     [ compiled-offset dup ] dip align swap - ;
 123
 124 : (align-code) ( n -- )
 125     0 <repetition> % ;
 126
 127 : align-code ( n -- )
 128     alignment (align-code) ;
 129
 130 : emit-data ( obj label -- )
 131     over length align-code
 132     resolve-label
 133     building get push-all ;
 134
 135 : emit-binary-literals ( -- )
 136     binary-literal-table get [ emit-data ] assoc-each ;
 137
 138 ! GC info
 139
 140 ! Every code block either ends with
 141 !
 142 ! uint 0
 143 !
 144 ! or
 145 !
 146 ! bitmap, byte aligned, three subsequences:
 147 ! - <scrubbed data stack locations>
 148 ! - <scrubbed retain stack locations>
 149 ! - <GC root spill slots>
 150 ! uint[] <base pointers>
 151 ! uint[] <return addresses>
 152 ! uint <largest scrubbed data stack location>
 153 ! uint <largest scrubbed retain stack location>
 154 ! uint <largest GC root spill slot>
 155 ! uint <largest derived root spill slot>
 156 ! int <number of return addresses>
 157 !
 158 SYMBOLS: return-addresses gc-maps ;
 159
 160 : gc-map-needed? ( gc-map -- ? )
 161     ! If there are no stack locations to scrub and no GC roots,
 162     ! there's no point storing the GC map.
 163     dup [
 164         {
 165             [ scrub-d>> empty? ]
 166             [ scrub-r>> empty? ]
 167             [ gc-roots>> empty? ]
 168             [ derived-roots>> empty? ]
 169         } 1&& not
 170     ] when ;
 171
 172 : gc-map-here ( gc-map -- )
 173     dup gc-map-needed? [
 174         gc-maps get push
 175         compiled-offset return-addresses get push
 176     ] [ drop ] if ;
 177
 178 : longest ( seqs -- n )
 179     [ length ] [ max ] map-reduce ;
 180
 181 : emit-scrub ( seqs -- n )
 182     ! seqs is a sequence of sequences of 0/1
 183     dup longest
 184     [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
 185
 186 : integers>bits ( seq n -- bit-array )
 187     <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
 188
 189 : largest-spill-slot ( seqs -- n )
 190     [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
 191
 192 : emit-gc-roots ( seqs -- n )
 193     ! seqs is a sequence of sequences of integers 0..n-1
 194     dup largest-spill-slot
 195     [ '[ _ integers>bits % ] each ] keep ;
 196
 197 : emit-uint ( n -- )
 198     building get push-uint ;
 199
 200 : emit-uints ( n -- )
 201     [ emit-uint ] each ;
 202
 203 : gc-root-offsets ( gc-map -- offsets )
 204     gc-roots>> [ gc-root-offset ] map ;
 205
 206 : emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count )
 207     [
 208         gc-maps get {
 209             [ [ scrub-d>> ] map emit-scrub ]
 210             [ [ scrub-r>> ] map emit-scrub ]
 211             [ [ gc-root-offsets ] map emit-gc-roots ]
 212         } cleave
 213     ] ?{ } make underlying>> % ;
 214
 215 : emit-base-table ( alist longest -- )
 216     -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
 217
 218 : derived-root-offsets ( gc-map -- offsets )
 219     derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
 220
 221 : emit-base-tables ( -- count )
 222     gc-maps get [ derived-root-offsets ] map
 223     dup [ keys ] map largest-spill-slot
 224     [ '[ _ emit-base-table ] each ] keep ;
 225
 226 : emit-return-addresses ( -- )
 227     return-addresses get emit-uints ;
 228
 229 : gc-info ( -- byte-array )
 230     [
 231         return-addresses get empty? [ 0 emit-uint ] [
 232             emit-gc-info-bitmaps
 233             emit-base-tables
 234             emit-return-addresses
 235             4array emit-uints
 236             return-addresses get length emit-uint
 237         ] if
 238     ] B{ } make ;
 239
 240 : emit-gc-info ( -- )
 241     ! We want to place the GC info so that the end is aligned
 242     ! on a 16-byte boundary.
 243     gc-info [
 244         length compiled-offset +
 245         [ data-alignment get align ] keep -
 246         (align-code)
 247     ] [ % ] bi ;
 248
 249 : init-fixup ( -- )
 250     V{ } clone parameter-table set
 251     V{ } clone literal-table set
 252     V{ } clone label-table set
 253     BV{ } clone relocation-table set
 254     V{ } clone binary-literal-table set
 255     V{ } clone return-addresses set
 256     V{ } clone gc-maps set ;
 257
 258 : check-fixup ( seq -- )
 259     length data-alignment get mod 0 assert= ;
 260
 261 : with-fixup ( quot -- code )
 262     '[
 263         init-fixup
 264         [
 265             @
 266             emit-binary-literals
 267             emit-gc-info
 268             label-table [ compute-labels ] change
 269             parameter-table get >array
 270             literal-table get >array
 271             relocation-table get >byte-array
 272             label-table get
 273         ] B{ } make
 274         dup check-fixup
 275     ] output>array ; inline