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