]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge Phil Dawes' VM work
authorSlava Pestov <slava@shill.local>
Sun, 20 Sep 2009 08:48:08 +0000 (03:48 -0500)
committerSlava Pestov <slava@shill.local>
Sun, 20 Sep 2009 08:48:08 +0000 (03:48 -0500)
1  2 
basis/compiler/codegen/codegen.factor
basis/cpu/ppc/ppc.factor
basis/cpu/x86/x86.factor

index ddf5aa0e02d8c07897d881440df300880e237fb9,f41bc853b53f507dfde54a6e6ac3266c218453ec..e1551f54c0fca0f728701f0fb471f85929227328
@@@ -270,6 -270,9 +270,9 @@@ M: ##alien-global generate-ins
      [ dst>> ] [ symbol>> ] [ library>> ] tri
      %alien-global ;
  
+ M: ##vm-field-ptr generate-insn
+     [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ;
  ! ##alien-invoke
  GENERIC: next-fastcall-param ( rep -- )
  
@@@ -434,7 -437,7 +437,7 @@@ M: ##alien-indirect generate-ins
      ! Generate code for boxing input parameters in a callback.
      [
          dup \ %save-param-reg move-parameters
-         "nest_stacks" f %alien-invoke
+         "nest_stacks" %vm-invoke-1st-arg
          box-parameters
      ] with-param-regs ;
  
@@@ -456,7 -459,7 +459,7 @@@ TUPLE: callback-context 
  
  : callback-return-quot ( ctype -- quot )
      return>> {
 -        { [ dup "void" = ] [ drop [ ] ] }
 +        { [ dup void? ] [ drop [ ] ] }
          { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
          [ c-type c-type-unboxer-quot ]
      } cond ;
          [ callback-context new do-callback ] %
      ] [ ] make ;
  
- : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
+ : %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
  
  M: ##callback-return generate-insn
      #! All the extra book-keeping for %unwind is only for x86.
diff --combined basis/cpu/ppc/ppc.factor
index 72ad54330725a24ac832834226b6201971212bc1,83f1bc9a74357f043c8bbd55ef020d45a58bd9a5..2a16a8b6df8511549bb39cf683881a50f2d3f93e
@@@ -2,14 -2,13 +2,14 @@@
  ! See http://factorcode.org/license.txt for BSD license.
  USING: accessors assocs sequences kernel combinators make math
  math.order math.ranges system namespaces locals layouts words
 -alien alien.accessors alien.c-types literals cpu.architecture
 +alien alien.accessors alien.c-types alien.data literals cpu.architecture
  cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
  compiler.cfg.instructions compiler.cfg.comparisons
  compiler.codegen.fixup compiler.cfg.intrinsics
  compiler.cfg.stack-frame compiler.cfg.build-stack-frame
- compiler.units compiler.constants compiler.codegen ;
+ compiler.units compiler.constants compiler.codegen vm ;
  FROM: cpu.ppc.assembler => B ;
 +FROM: math => float ;
  IN: cpu.ppc
  
  ! PowerPC register assignments:
@@@ -30,6 -29,18 +30,18 @@@ enable-float-intrinsic
  \ ##float>integer t frame-required? set-word-prop
  >>
  
+ : %load-vm-addr ( reg -- )
+     0 swap LOAD32 rc-absolute-ppc-2/2 rt-vm rel-fixup ;
+ : %load-vm-field-addr ( reg symbol -- )
+     [ drop %load-vm-addr ]
+     [ [ dup ] dip vm-field-offset ADDI ] 2bi ;
+ M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
+ M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
+ M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
  M: ppc machine-registers
      {
          { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
@@@ -419,7 -430,7 +431,7 @@@ M: ppc %set-alien-float swap 0 STFS 
  M: ppc %set-alien-double swap 0 STFD ;
  
  : load-zone-ptr ( reg -- )
-     "nursery" f %alien-global ;
+     "nursery" %load-vm-field-addr ;
  
  : load-allot-ptr ( nursery-ptr allot-ptr -- )
      [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
@@@ -442,10 -453,10 +454,10 @@@ M:: ppc %allot ( dst size class nursery
      dst class store-tagged ;
  
  : load-cards-offset ( dst -- )
-     [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
+     [ "cards_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi ;
  
  : load-decks-offset ( dst -- )
-     [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi  ;
+     [ "decks_offset" %load-vm-field-addr ] [ dup 0 LWZ ] bi  ;
  
  M:: ppc %write-barrier ( src card# table -- )
      card-mark scratch-reg LI
@@@ -683,7 -694,7 +695,7 @@@ M:: ppc %save-context ( temp1 temp2 cal
      #! Save Factor stack pointers in case the C code calls a
      #! callback which does a GC, which must reliably trace
      #! all roots.
-     temp1 "stack_chain" f %alien-global
+     temp1 "stack_chain" %load-vm-field-addr
      temp1 temp1 0 LWZ
      1 temp1 0 STW
      callback-allowed? [
@@@ -771,5 -782,5 +783,5 @@@ USE: vocabs.loade
          4 >>align
          "box_boolean" >>boxer
          "to_boolean" >>unboxer
 -    "bool" define-primitive-type
 +    bool define-primitive-type
  ] with-compilation-unit
diff --combined basis/cpu/x86/x86.factor
index 04b530883653533837fb34b40a7c7ad7368a5a67,91705efec6d46a39e367d90a6a15bde6bdff46b6..97bd2f78ded9c8ef7a4699b9562f42e25c814b46
@@@ -4,15 -4,14 +4,14 @@@ USING: accessors assocs alien alien.c-t
  cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
  cpu.architecture kernel kernel.private math memory namespaces make
  sequences words system layouts combinators math.order fry locals
--compiler.constants byte-arrays
++compiler.constants vm byte-arrays
  compiler.cfg.registers
  compiler.cfg.instructions
  compiler.cfg.intrinsics
  compiler.cfg.comparisons
  compiler.cfg.stack-frame
--compiler.codegen
 -compiler.codegen.fixup vm ;
 +compiler.codegen.fixup ;
 +FROM: math => float ;
  IN: cpu.x86
  
  << enable-fixnum-log2 >>
@@@ -556,9 -555,13 +555,13 @@@ M: x86 %shl [ SHL ] emit-shift 
  M: x86 %shr [ SHR ] emit-shift ;
  M: x86 %sar [ SAR ] emit-shift ;
  
+ M: x86 %vm-field-ptr ( dst field -- )
+     [ drop 0 MOV rc-absolute-cell rt-vm rel-fixup ]
+     [ vm-field-offset ADD ] 2bi ;
  : load-zone-ptr ( reg -- )
      #! Load pointer to start of zone array
-     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+     "nursery" %vm-field-ptr ;
  
  : load-allot-ptr ( nursery-ptr allot-ptr -- )
      [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
@@@ -578,18 -581,19 +581,19 @@@ M:: x86 %allot ( dst size class nursery
      dst class store-tagged
      nursery-ptr size inc-allot-ptr ;
  
  M:: x86 %write-barrier ( src card# table -- )
      #! Mark the card pointed to by vreg.
      ! Mark the card
      card# src MOV
      card# card-bits SHR
-     table "cards_offset" f %alien-global
+     table "cards_offset" %vm-field-ptr
      table table [] MOV
      table card# [+] card-mark <byte> MOV
  
      ! Mark the card deck
      card# deck-bits card-bits - SHR
-     table "decks_offset" f %alien-global
+     table "decks_offset" %vm-field-ptr
      table table [] MOV
      table card# [+] card-mark <byte> MOV ;
  
@@@ -611,10 -615,10 +615,10 @@@ M:: x86 %call-gc ( gc-root-count -- 
      ! Pass number of roots as second parameter
      param-reg-2 gc-root-count MOV
      ! Call GC
-     "inline_gc" f %alien-invoke ;
+     "inline_gc" %vm-invoke-3rd-arg ; 
  
- M: x86 %alien-global
-     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+ M: x86 %alien-global ( dst symbol library -- )
+     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;    
  
  M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
  
@@@ -743,8 -747,8 +747,8 @@@ M:: x86 %save-context ( temp1 temp2 cal
      #! Save Factor stack pointers in case the C code calls a
      #! callback which does a GC, which must reliably trace
      #! all roots.
-     temp1 "stack_chain" f %alien-global
-     temp1 temp1 [] MOV
+     temp1 0 MOV rc-absolute-cell rt-vm rel-fixup
+     temp1 temp1 "stack_chain" vm-field-offset [+] MOV
      temp2 stack-reg cell neg [+] LEA
      temp1 [] temp2 MOV
      callback-allowed? [