core/compiler/generator/xt.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler
   4 USING: alien arrays assembler errors generic hashtables kernel
   5 kernel-internals math namespaces prettyprint queues
   6 sequences strings vectors words ;
   7
   8 DEFER: (compile)
   9
  10 : compiled-offset ( -- n ) building get length code-format * ;
  11
  12 TUPLE: label offset ;
  13
  14 C: label ( -- label ) ;
  15
  16 : define-label ( name -- ) <label> swap set ;
  17
  18 : resolve-label ( label/name -- )
  19     dup string? [ get ] when
  20     compiled-offset swap set-label-offset ;
  21
  22 SYMBOL: compiled-xts
  23
  24 : save-xt ( word xt -- )
  25     swap dup unchanged-word compiled-xts get set-hash ;
  26
  27 : push-new* ( obj table -- n )
  28     2dup [ eq? ] find-with drop dup -1 > [
  29         2nip
  30     ] [
  31         drop dup length >r push r>
  32     ] if ;
  33
  34 SYMBOL: literal-table
  35
  36 : add-literal ( obj -- n ) literal-table get push-new* ;
  37
  38 SYMBOL: word-table
  39
  40 : add-word ( word -- n ) word-table get push-new* ;
  41
  42 SYMBOL: relocation-table
  43 SYMBOL: label-table
  44
  45 : rel-absolute-cell 0 ;
  46 : rel-absolute 1 ;
  47 : rel-relative 2 ;
  48 : rel-absolute-2/2 3 ;
  49 : rel-relative-2/2 4 ;
  50 : rel-relative-2 5 ;
  51 : rel-relative-3 6 ;
  52
  53 : (rel) ( arg class type offset -- pair )
  54     #! Write a relocation instruction for the runtime image
  55     #! loader.
  56     pick rel-absolute-cell = cell 4 ? -
  57     >r >r >r 16 shift r> 8 shift bitor r> bitor r>
  58     2array ;
  59
  60 : rel, ( arg class type -- )
  61     compiled-offset (rel) relocation-table get swap nappend ;
  62
  63 : rel-dlsym ( name dll class -- )
  64    >r >r string>char-alien r> 2array add-literal r> 1 rel, ;
  65
  66 : rel-here ( class -- )
  67     dup rel-relative = [ drop ] [ 0 swap 2 rel, ] if ;
  68
  69 : rel-word ( word class -- )
  70     over primitive?
  71     [ >r word-primitive r> 0 ] [ >r add-word r> 5 ] if
  72     rel, ;
  73
  74 : rel-cards ( class -- ) 0 swap 3 rel, ;
  75
  76 : rel-literal ( literal class -- )
  77     >r add-literal r> 4 rel, ;
  78
  79 : rel-label ( label class -- )
  80     compiled-offset 3array label-table get push ;
  81
  82 : generate-labels ( -- )
  83     label-table get [
  84         first3 >r >r label-offset r> 6 r> (rel)
  85         relocation-table get swap nappend
  86     ] each ;
  87
  88 : compiling? ( word -- ? )
  89     {
  90         { [ dup compiled-xts get hash-member? ] [ drop t ] }
  91         { [ dup word-changed? ] [ drop f ] }
  92         { [ t ] [ compiled? ] }
  93     } cond ;
  94
  95 : with-compiler ( quot -- )
  96     [
  97         H{ } clone compiled-xts set
  98         call
  99         compiled-xts get hash>alist finalize-compile
 100     ] with-scope ;