basis/compiler/codegen/fixup/fixup.factor

   1 ! Copyright (C) 2007, 2009 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
   7 accessors growable fry generalizations compiler.constants ;
   8 IN: compiler.codegen.fixup
   9
  10 ! Owner
  11 SYMBOL: compiling-word
  12
  13 ! Literal table
  14 SYMBOL: literal-table
  15
  16 : add-literal ( obj -- ) literal-table get push ;
  17
  18 ! Labels
  19 SYMBOL: label-table
  20
  21 TUPLE: label offset ;
  22
  23 : <label> ( -- label ) label new ;
  24 : define-label ( name -- ) <label> swap set ;
  25
  26 : compiled-offset ( -- n ) building get length ;
  27
  28 : resolve-label ( label/name -- )
  29     dup label? [ get ] unless
  30     compiled-offset >>offset drop ;
  31
  32 : offset-for-class ( class -- n )
  33     rc-absolute-cell = cell 4 ? compiled-offset swap - ;
  34
  35 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
  36
  37 : label-fixup ( label class -- )
  38     dup offset-for-class \ label-fixup boa label-table get push ;
  39
  40 ! Relocation table
  41 SYMBOL: relocation-table
  42
  43 : push-4 ( value vector -- )
  44     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  45     swap set-alien-unsigned-4 ;
  46
  47 : add-relocation-entry ( type class offset -- )
  48     { 0 24 28 } bitfield relocation-table get push-4 ;
  49
  50 : rel-fixup ( class type -- )
  51     swap dup offset-for-class add-relocation-entry ;
  52
  53 : add-dlsym-literals ( symbol dll -- )
  54     [ string>symbol add-literal ] [ add-literal ] bi* ;
  55
  56 : rel-dlsym ( name dll class -- )
  57     [ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
  58
  59 : rel-word ( word class -- )
  60     [ add-literal ] dip rt-xt rel-fixup ;
  61
  62 : rel-word-pic ( word class -- )
  63     [ add-literal ] dip rt-xt-pic rel-fixup ;
  64
  65 : rel-word-pic-tail ( word class -- )
  66     [ add-literal ] dip rt-xt-pic-tail rel-fixup ;
  67
  68 : rel-primitive ( word class -- )
  69     [ def>> first add-literal ] dip rt-primitive rel-fixup ;
  70
  71 : rel-immediate ( literal class -- )
  72     [ add-literal ] dip rt-immediate rel-fixup ;
  73
  74 : rel-this ( class -- )
  75     rt-this rel-fixup ;
  76
  77 : rel-here ( offset class -- )
  78     [ add-literal ] dip rt-here rel-fixup ;
  79
  80 : rel-vm ( offset class -- )
  81     [ add-literal ] dip rt-vm rel-fixup ;
  82
  83 : rel-cards-offset ( class -- )
  84     rt-cards-offset rel-fixup ;
  85
  86 : rel-decks-offset ( class -- )
  87     rt-decks-offset rel-fixup ;
  88
  89 ! And the rest
  90 : resolve-offset ( label-fixup -- offset )
  91     label>> offset>> [ "Unresolved label" throw ] unless* ;
  92
  93 : resolve-absolute-label ( label-fixup -- )
  94     dup resolve-offset neg add-literal
  95     [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
  96
  97 : resolve-relative-label ( label-fixup -- label )
  98     [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
  99
 100 : resolve-labels ( label-fixups -- labels' )
 101     [ class>> rc-absolute? ] partition
 102     [ [ resolve-absolute-label ] each ]
 103     [ [ resolve-relative-label ] map concat ]
 104     bi* ;
 105
 106 : init-fixup ( word -- )
 107     compiling-word set
 108     V{ } clone literal-table set
 109     V{ } clone label-table set
 110     BV{ } clone relocation-table set ;
 111
 112 : with-fixup ( word quot -- code )
 113     '[
 114         init-fixup
 115         @
 116         label-table [ resolve-labels ] change
 117         compiling-word get
 118         literal-table get >array
 119         relocation-table get >byte-array
 120         label-table get
 121     ] B{ } make 5 narray ; inline