2005-02-22 23:07:47 -05:00
|
|
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2004-12-02 22:44:36 -05:00
|
|
|
IN: compiler
|
2005-04-02 02:39:33 -05:00
|
|
|
USING: assembler errors inference kernel lists math namespaces
|
|
|
|
sequences strings vectors words ;
|
2004-12-25 02:55:03 -05:00
|
|
|
|
|
|
|
: generate-code ( word linear -- length )
|
|
|
|
compiled-offset >r
|
|
|
|
compile-aligned
|
|
|
|
swap save-xt
|
|
|
|
[ generate-node ] each
|
|
|
|
compile-aligned
|
|
|
|
compiled-offset r> - ;
|
|
|
|
|
|
|
|
: generate-reloc ( -- length )
|
|
|
|
relocation-table get
|
2005-04-02 02:39:33 -05:00
|
|
|
dup [ compile-cell ] seq-each
|
2005-04-26 00:35:55 -04:00
|
|
|
length cell * ;
|
2004-12-25 02:55:03 -05:00
|
|
|
|
2004-12-25 15:52:08 -05:00
|
|
|
: (generate) ( word linear -- )
|
2004-12-01 19:48:08 -05:00
|
|
|
#! Compile a word definition from linear IR.
|
2004-12-25 02:55:03 -05:00
|
|
|
100 <vector> relocation-table set
|
|
|
|
begin-assembly swap >r >r
|
|
|
|
generate-code
|
|
|
|
generate-reloc
|
|
|
|
r> set-compiled-cell
|
|
|
|
r> set-compiled-cell ;
|
2004-12-04 23:45:41 -05:00
|
|
|
|
2004-12-25 15:52:08 -05:00
|
|
|
SYMBOL: previous-offset
|
|
|
|
|
|
|
|
: generate ( word linear -- )
|
|
|
|
#! If generation fails, reset compiled offset.
|
|
|
|
[
|
|
|
|
compiled-offset previous-offset set
|
|
|
|
(generate)
|
|
|
|
] [
|
|
|
|
[
|
|
|
|
previous-offset get set-compiled-offset
|
|
|
|
rethrow
|
|
|
|
] when*
|
|
|
|
] catch ;
|
|
|
|
|
2005-05-06 18:33:40 -04:00
|
|
|
! A few VOPs have trivial generators.
|
2004-12-31 02:17:45 -05:00
|
|
|
|
2005-05-06 18:33:40 -04:00
|
|
|
M: %label generate-node ( vop -- )
|
|
|
|
vop-label save-xt ;
|
2005-01-17 15:33:12 -05:00
|
|
|
|
2005-05-06 18:33:40 -04:00
|
|
|
M: %end-dispatch generate-node ( vop -- ) drop ;
|
2005-03-15 22:23:52 -05:00
|
|
|
|
2005-03-19 21:23:21 -05:00
|
|
|
: compile-target ( word -- ) 0 compile-cell absolute ;
|
|
|
|
|
2005-05-06 18:33:40 -04:00
|
|
|
M: %target-label generate-node vop-label compile-target ;
|
2005-03-19 21:23:21 -05:00
|
|
|
|
2005-05-06 18:33:40 -04:00
|
|
|
M: %target generate-node
|
|
|
|
vop-label dup postpone-word compile-target ;
|