compiler.cfg: refactor stack frame code and fix frame pointer usage in callbacks

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math math.order assocs kernel sequences
-combinators classes words cpu.architecture layouts compiler.cfg
+combinators classes words system cpu.architecture layouts compiler.cfg
 compiler.cfg.rpo compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.stack-frame ;
 IN: compiler.cfg.build-stack-frame
@@ -17,18 +17,33 @@ GENERIC: compute-stack-frame* ( insn -- )
 M: ##stack-frame compute-stack-frame*
     stack-frame>> request-stack-frame ;
 
-M: ##call-gc compute-stack-frame*
-    drop
-    frame-required? on
+: frame-required ( -- ) frame-required? on ;
+
+: vm-frame-required ( -- )
+    frame-required
     stack-frame new t >>calls-vm? request-stack-frame ;
 
-M: ##call compute-stack-frame* drop frame-required? on ;
+M: ##call-gc compute-stack-frame* drop vm-frame-required ;
+M: ##box compute-stack-frame* drop vm-frame-required ;
+M: ##unbox compute-stack-frame* drop vm-frame-required ;
+M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
+M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
+M: ##end-callback compute-stack-frame* drop vm-frame-required ;
+M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
+M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
 
-M: ##alien-callback compute-stack-frame* drop frame-required? on ;
+M: ##call compute-stack-frame* drop frame-required ;
+M: ##alien-callback compute-stack-frame* drop frame-required ;
+M: ##spill compute-stack-frame* drop frame-required ;
+M: ##reload compute-stack-frame* drop frame-required ;
 
-M: insn compute-stack-frame*
-    class "frame-required?" word-prop
-    [ frame-required? on ] when ;
+M: ##float>integer compute-stack-frame*
+    drop cpu ppc? [ frame-required ] when ;
+
+M: ##integer>float compute-stack-frame*
+    drop cpu ppc? [ frame-required ] when ;
+
+M: insn compute-stack-frame* drop ;
 
 : initial-stack-frame ( -- stack-frame )
     stack-frame new cfg get spill-area-size>> >>spill-area-size ;

basis/compiler/cfg/builder/alien/alien.factor

@@ -178,9 +178,14 @@ M: #alien-assembly emit-node
     [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
     "stack-cleanup" set-word-prop ;
 
+: needs-frame-pointer ( -- )
+    cfg get t >>frame-pointer? drop ;
+
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
+        needs-frame-pointer
+
         ##prologue
         [
             {

basis/compiler/cfg/cfg.factor

@@ -24,6 +24,7 @@ M: basic-block hashcode* nip id>> ;
 TUPLE: cfg { entry basic-block } word label
 spill-area-size
 stack-frame
+frame-pointer?
 post-order linear-order
 predecessors-valid? dominance-valid? loops-valid? ;
 

basis/compiler/cfg/linear-scan/linear-scan.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make locals
+USING: kernel accessors assocs sequences namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
@@ -37,5 +37,12 @@ IN: compiler.cfg.linear-scan
     cfg resolve-data-flow
     cfg check-numbering ;
 
+: admissible-registers ( cfg -- regs )
+    [ machine-registers ] dip
+    frame-pointer?>> [
+        [ int-regs ] dip clone
+        [ [ [ frame-reg ] dip remove ] change-at ] keep
+    ] unless ;
+
 : linear-scan ( cfg -- cfg' )
-    dup machine-registers (linear-scan) ;
+    dup dup admissible-registers (linear-scan) ;

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -30,8 +30,3 @@ TUPLE: stack-frame
         [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
         [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
     } 2cleave ;
-
-! PowerPC backend sets frame-required? for ##integer>float too
-\ ##spill t "frame-required?" set-word-prop
-\ ##unary-float-function t "frame-required?" set-word-prop
-\ ##binary-float-function t "frame-required?" set-word-prop

basis/cpu/architecture/architecture.factor

@@ -212,6 +212,9 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
 ! Mapping from register class to machine registers
 HOOK: machine-registers cpu ( -- assoc )
 
+! Callbacks are not allowed to clobber this
+HOOK: frame-reg cpu ( -- reg )
+
 ! Specifies if %slot, %set-slot and %write-barrier accept the
 ! 'scale' and 'tag' parameters, and if %load-memory and
 ! %store-memory work

basis/cpu/ppc/ppc.factor

@@ -32,11 +32,6 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 enable-float-intrinsics
 
-<<
-\ ##integer>float t "frame-required?" set-word-prop
-\ ##float>integer t "frame-required?" set-word-prop
->>
-
 M: ppc machine-registers
     {
         { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }

basis/cpu/x86/32/32.factor

@@ -112,12 +112,12 @@ M: x86.32 %prepare-jump
         dst ESP [] sse-insn execute
         ESP 4 ADD
     ] [
-        dst x87-insn execute
+        dst ?spill-slot x87-insn execute
     ] if ; inline
 
 M: x86.32 %load-reg-param ( dst reg rep -- )
-    [ ?spill-slot ] dip {
-        { int-rep [ MOV ] }
+    {
+        { int-rep [ int-rep %copy ] }
         { float-rep [ drop \ FSTPS \ MOVSS load-float-return ] }
         { double-rep [ drop \ FSTPL \ MOVSD load-float-return ] }
     } case ;
@@ -129,14 +129,14 @@ M: x86.32 %load-reg-param ( dst reg rep -- )
         ESP [] x87-insn execute
         ESP 4 ADD
     ] [
-        src x87-insn execute
+        src ?spill-slot x87-insn execute
     ] if ; inline
 
 M: x86.32 %store-reg-param ( src reg rep -- )
-    [ ?spill-slot ] dip {
-        { int-rep [ swap MOV ] }
-        { float-rep [ \ FLDS \ MOVSS store-float-return ] }
-        { double-rep [ \ FLDL \ MOVSD store-float-return ] }
+    {
+        { int-rep [ swap int-rep %copy ] }
+        { float-rep [ drop \ FLDS \ MOVSS store-float-return ] }
+        { double-rep [ drop \ FLDL \ MOVSD store-float-return ] }
     } case ;
 
 :: call-unbox-func ( src func -- )
@@ -158,8 +158,10 @@ M:: x86.32 %box ( dst src func rep -- )
 
 M:: x86.32 %box-long-long ( dst src1 src2 func -- )
     8 save-vm-ptr
-    4 stack@ src1 int-rep %copy
-    0 stack@ src2 int-rep %copy
+    EAX src1 int-rep %copy
+    0 stack@ EAX int-rep %copy
+    EAX src2 int-rep %copy
+    4 stack@ EAX int-rep %copy
     func f %alien-invoke
     dst EAX tagged-rep %copy ;
 

basis/cpu/x86/x86.factor

@@ -26,8 +26,6 @@ M: x86 vector-regs float-regs ;
 
 HOOK: stack-reg cpu ( -- reg )
 
-HOOK: frame-reg cpu ( -- reg )
-
 HOOK: reserved-stack-space cpu ( -- n )
 
 HOOK: extra-stack-space cpu ( stack-frame -- n )
@@ -1573,6 +1571,8 @@ M: x86 %loop-entry 16 alignment [ NOP ] times ;
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
     temp1 %context
+    temp2 stack-reg cell neg [+] LEA
+    temp1 "callstack-top" context-field-offset [+] temp2 MOV
     ds-reg temp1 "datastack" context-field-offset [+] MOV
     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;