basis/compiler/generator/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 generic assocs hashtables io.binary
   4 kernel kernel.private math namespaces sequences words
   5 quotations strings alien.accessors alien.strings layouts system
   6 combinators math.bitwise words.private cpu.architecture
   7 math.order accessors growable ;
   8 IN: compiler.generator.fixup
   9
  10 : no-stack-frame -1 ; inline
  11
  12 TUPLE: frame-required n ;
  13
  14 : frame-required ( n -- ) \ frame-required boa , ;
  15
  16 : stack-frame-size ( code -- n )
  17     no-stack-frame [
  18         dup frame-required? [ n>> max ] [ drop ] if
  19     ] reduce ;
  20
  21 GENERIC: fixup* ( frame-size obj -- frame-size )
  22
  23 : code-format 22 getenv ;
  24
  25 : compiled-offset ( -- n ) building get length code-format * ;
  26
  27 TUPLE: label offset ;
  28
  29 : <label> ( -- label ) label new ;
  30
  31 M: label fixup*
  32     compiled-offset >>offset drop ;
  33
  34 : define-label ( name -- ) <label> swap set ;
  35
  36 : resolve-label ( label/name -- ) dup label? [ get ] unless , ;
  37
  38 : if-stack-frame ( frame-size quot -- )
  39     swap dup no-stack-frame =
  40     [ 2drop ] [ stack-frame swap call ] if ; inline
  41
  42 M: word fixup*
  43     {
  44         { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
  45         { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
  46     } case ;
  47
  48 SYMBOL: relocation-table
  49 SYMBOL: label-table
  50
  51 ! Relocation classes
  52 : rc-absolute-cell     0 ;
  53 : rc-absolute          1 ;
  54 : rc-relative          2 ;
  55 : rc-absolute-ppc-2/2  3 ;
  56 : rc-relative-ppc-2    4 ;
  57 : rc-relative-ppc-3    5 ;
  58 : rc-relative-arm-3    6 ;
  59 : rc-indirect-arm      7 ;
  60 : rc-indirect-arm-pc   8 ;
  61
  62 : rc-absolute? ( n -- ? )
  63     dup rc-absolute-cell =
  64     over rc-absolute =
  65     rot rc-absolute-ppc-2/2 = or or ;
  66
  67 ! Relocation types
  68 : rt-primitive 0 ;
  69 : rt-dlsym     1 ;
  70 : rt-literal   2 ;
  71 : rt-dispatch  3 ;
  72 : rt-xt        4 ;
  73 : rt-here      5 ;
  74 : rt-label     6 ;
  75 : rt-immediate 7 ;
  76
  77 TUPLE: label-fixup label class ;
  78
  79 : label-fixup ( label class -- ) \ label-fixup boa , ;
  80
  81 M: label-fixup fixup*
  82     dup class>> rc-absolute?
  83     [ "Absolute labels not supported" throw ] when
  84     dup label>> swap class>> compiled-offset 4 - rot
  85     3array label-table get push ;
  86
  87 TUPLE: rel-fixup arg class type ;
  88
  89 : rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
  90
  91 : push-4 ( value vector -- )
  92     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  93     swap set-alien-unsigned-4 ;
  94
  95 M: rel-fixup fixup*
  96     [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
  97     [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
  98     [ relocation-table get push-4 ] bi@ ;
  99
 100 M: frame-required fixup* drop ;
 101
 102 M: integer fixup* , ;
 103
 104 : adjoin* ( obj table -- n )
 105     2dup swap [ eq? ] curry find drop
 106     [ 2nip ] [ dup length >r push r> ] if* ;
 107
 108 SYMBOL: literal-table
 109
 110 : add-literal ( obj -- n ) literal-table get adjoin* ;
 111
 112 : add-dlsym-literals ( symbol dll -- )
 113     >r string>symbol r> 2array literal-table get push-all ;
 114
 115 : rel-dlsym ( name dll class -- )
 116     >r literal-table get length >r
 117     add-dlsym-literals
 118     r> r> rt-dlsym rel-fixup ;
 119
 120 : rel-word ( word class -- )
 121     >r add-literal r> rt-xt rel-fixup ;
 122
 123 : rel-primitive ( word class -- )
 124     >r def>> first r> rt-primitive rel-fixup ;
 125
 126 : rel-literal ( literal class -- )
 127     >r add-literal r> rt-literal rel-fixup ;
 128
 129 : rel-this ( class -- )
 130     0 swap rt-label rel-fixup ;
 131
 132 : rel-here ( class -- )
 133     0 swap rt-here rel-fixup ;
 134
 135 : init-fixup ( -- )
 136     BV{ } clone relocation-table set
 137     V{ } clone label-table set ;
 138
 139 : resolve-labels ( labels -- labels' )
 140     [
 141         first3 offset>>
 142         [ "Unresolved label" throw ] unless*
 143         3array
 144     ] map concat ;
 145
 146 : fixup ( code -- literals relocation labels code )
 147     [
 148         init-fixup
 149         dup stack-frame-size swap [ fixup* ] each drop
 150
 151         literal-table get >array
 152         relocation-table get >byte-array
 153         label-table get resolve-labels
 154     ] { } make ;