basis/compiler/codegen/labels/labels.factor

   1 ! Copyright (C) 2007, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs compiler.codegen.relocation
   4 compiler.constants kernel make math namespaces sequences ;
   5 IN: compiler.codegen.labels
   6
   7 ! Labels
   8 SYMBOL: label-table
   9
  10 TUPLE: label offset ;
  11
  12 : <label> ( -- label ) label new ;
  13 : define-label ( name -- ) <label> swap set ;
  14
  15 : resolve-label ( label/name -- )
  16     dup label? [ get ] unless
  17     compiled-offset >>offset drop ;
  18
  19 TUPLE: label-fixup { label label } { class integer } { offset integer } ;
  20
  21 : label-fixup ( label class -- )
  22     compiled-offset \ label-fixup boa label-table get push ;
  23
  24 : compute-target ( label-fixup -- offset )
  25     label>> offset>> [ "Unresolved label" throw ] unless* ;
  26
  27 : compute-relative-label ( label-fixup -- label )
  28     [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
  29
  30 : compute-absolute-label ( label-fixup -- )
  31     [ compute-target neg add-literal ]
  32     [ [ class>> rt-here ] [ offset>> ] bi add-relocation-at ] bi ;
  33
  34 : compute-labels ( label-fixups -- labels' )
  35     [ class>> rc-absolute? ] partition
  36     [ [ compute-absolute-label ] each ]
  37     [ [ compute-relative-label ] map concat ]
  38     bi* ;
  39
  40 ! Binary literals
  41 SYMBOL: binary-literal-table
  42
  43 : add-binary-literal ( obj -- label )
  44     <label> [ 2array binary-literal-table get push ] keep ;
  45
  46 : rel-binary-literal ( literal class -- )
  47     [ add-binary-literal ] dip label-fixup ;
  48
  49 : emit-data ( obj label -- )
  50     over length align-code
  51     resolve-label
  52     building get push-all ;
  53
  54 : emit-binary-literals ( -- )
  55     binary-literal-table get [ emit-data ] assoc-each ;