From 6cad2e02e495b9adde0a094c2f3b743ecefe917e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 17 Sep 2008 00:46:38 -0500
Subject: [PATCH] Updating x86 backend for new codegen
---
basis/compiler/constants/constants.factor | 27 +
unfinished/compiler/backend/backend.factor | 221 ++++-
unfinished/compiler/backend/x86/32/32.factor | 313 +++++++-
unfinished/compiler/backend/x86/64/64.factor | 218 ++++-
.../compiler/backend/x86/sse2/sse2.factor | 110 +++
unfinished/compiler/backend/x86/x86.factor | 755 ++++++++++++++++++
.../compiler/cfg/builder/builder.factor | 109 ++-
unfinished/compiler/cfg/cfg.factor | 7 +-
.../compiler/cfg/debugger/debugger.factor | 5 +-
.../cfg/instructions/instructions.factor | 115 ++-
.../cfg/linear-scan/linear-scan-tests.factor | 5 +
.../cfg/linear-scan/linear-scan.factor | 13 +-
.../live-intervals/live-intervals.factor | 1 -
.../cfg/linearization/linearization.factor | 42 +-
.../compiler/cfg/registers/registers.factor | 22 +-
unfinished/compiler/cfg/rpo/rpo.factor | 1 -
unfinished/compiler/cfg/stacks/stacks.factor | 91 +--
.../compiler/cfg/templates/templates.factor | 31 +-
.../alien.factor => codegen/codegen.factor} | 222 +++--
.../compiler/codegen/fixup/fixup.factor | 77 +-
unfinished/compiler/new/new.factor | 116 +++
21 files changed, 2134 insertions(+), 367 deletions(-)
create mode 100644 unfinished/compiler/backend/x86/sse2/sse2.factor
create mode 100644 unfinished/compiler/backend/x86/x86.factor
rename unfinished/compiler/{backend/alien/alien.factor => codegen/codegen.factor} (58%)
create mode 100644 unfinished/compiler/new/new.factor
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 80f0b4f515..b5b2be5095 100755
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -23,3 +23,30 @@ IN: compiler.constants
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+
+! Relocation classes
+: rc-absolute-cell 0 ;
+: rc-absolute 1 ;
+: rc-relative 2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2 4 ;
+: rc-relative-ppc-3 5 ;
+: rc-relative-arm-3 6 ;
+: rc-indirect-arm 7 ;
+: rc-indirect-arm-pc 8 ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym 1 ;
+: rt-literal 2 ;
+: rt-dispatch 3 ;
+: rt-xt 4 ;
+: rt-here 5 ;
+: rt-label 6 ;
+: rt-immediate 7 ;
+
+: rc-absolute? ( n -- ? )
+ [ rc-absolute-ppc-2/2 = ]
+ [ rc-absolute-cell = ]
+ [ rc-absolute = ]
+ tri or or ;
diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor
index c1944eb9a7..ffe8f73ba9 100644
--- a/unfinished/compiler/backend/backend.factor
+++ b/unfinished/compiler/backend/backend.factor
@@ -1,10 +1,223 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system ;
+USING: accessors assocs arrays generic kernel kernel.private
+math memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words sets classes.algebra
+compiler.cfg.registers compiler.cfg.instructions ;
IN: compiler.backend
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( size -- ? )
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
+
+! A pseudo-register class for parameters spilled on the stack
+SINGLETON: stack-params
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: param-regs ( register-class -- regs )
+
+GENERIC: param-reg ( n register-class -- reg )
+
+M: object param-reg param-regs nth ;
+
+! Load a literal (immediate or indirect)
+GENERIC# load-literal 1 ( obj vreg -- )
+
+HOOK: load-indirect cpu ( obj reg -- )
+
+HOOK: stack-frame cpu ( frame-size -- n )
+
+: stack-frame* ( -- n )
+ \ stack-frame get stack-frame ;
+
+! Set up caller stack frame
+HOOK: %prologue cpu ( n -- )
+
+! Tear down stack frame
+HOOK: %epilogue cpu ( n -- )
+
+! Call another word
+HOOK: %call cpu ( word -- )
+
+! Local jump for branches
+HOOK: %jump-label cpu ( label -- )
+
+! Test if vreg is 'f' or not
+HOOK: %jump-f cpu ( label vreg -- )
+
+! Test if vreg is 't' or not
+HOOK: %jump-t cpu ( label vreg -- )
+
+HOOK: %dispatch cpu ( -- )
+
+HOOK: %dispatch-label cpu ( word -- )
+
+! Return to caller
+HOOK: %return cpu ( -- )
+
+! Change datastack height
+HOOK: %inc-d cpu ( n -- )
+
+! Change callstack height
+HOOK: %inc-r cpu ( n -- )
+
+! Load stack into vreg
+HOOK: %peek cpu ( vreg loc -- )
+
+! Store vreg to stack
+HOOK: %replace cpu ( vreg loc -- )
+
+! Copy values between vregs
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+
+! Box and unbox floats
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
+
+! FFI stuff
+
+! Is this integer small enough to appear in value template
+! slots?
+HOOK: small-enough? cpu ( n -- ? )
+
+! Is this structure small enough to be returned in registers?
+HOOK: struct-small-enough? cpu ( heap-size -- ? )
+
+! Do we pass explode value structs?
+HOOK: value-structs? cpu ( -- ? )
+
+! If t, fp parameters are shadowed by dummy int parameters
+HOOK: fp-shadows-int? cpu ( -- ? )
+
+HOOK: %prepare-unbox cpu ( -- )
+
+HOOK: %unbox cpu ( n reg-class func -- )
+
+HOOK: %unbox-long-long cpu ( n func -- )
+
+HOOK: %unbox-small-struct cpu ( c-type -- )
+
+HOOK: %unbox-large-struct cpu ( n c-type -- )
+
+HOOK: %box cpu ( n reg-class func -- )
+
+HOOK: %box-long-long cpu ( n func -- )
+
+HOOK: %prepare-box-struct cpu ( size -- )
+
+HOOK: %box-small-struct cpu ( c-type -- )
+
+HOOK: %box-large-struct cpu ( n c-type -- )
+
+GENERIC: %save-param-reg ( stack reg reg-class -- )
+
+GENERIC: %load-param-reg ( stack reg reg-class -- )
+
+HOOK: %prepare-alien-invoke cpu ( -- )
+
+HOOK: %prepare-var-args cpu ( -- )
+
+M: object %prepare-var-args ;
+
+HOOK: %alien-invoke cpu ( function library -- )
+
+HOOK: %cleanup cpu ( alien-node -- )
+
+HOOK: %alien-callback cpu ( quot -- )
+
+HOOK: %callback-value cpu ( ctype -- )
+
+! Return to caller with stdcall unwinding (only for x86)
+HOOK: %unwind cpu ( n -- )
+
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
+
+M: stack-params param-reg drop ;
+
+M: stack-params param-regs drop f ;
+
+GENERIC: v>operand ( obj -- operand )
+
+SYMBOL: registers
+
+M: constant v>operand
+ value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+M: value v>operand
+ >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+
+M: object load-literal v>operand load-indirect ;
+
+PREDICATE: small-slot < integer cells small-enough? ;
+
+PREDICATE: small-tagged < integer v>operand small-enough? ;
+
+: if-small-struct ( n size true false -- ? )
+ [ over not over struct-small-enough? and ] 2dip
+ [ [ nip ] prepose ] dip if ;
+ inline
+
+: %unbox-struct ( n c-type -- )
+ [
+ %unbox-small-struct
+ ] [
+ %unbox-large-struct
+ ] if-small-struct ;
+
+: %box-struct ( n c-type -- )
+ [
+ %box-small-struct
+ ] [
+ %box-large-struct
+ ] if-small-struct ;
+
+! Alien accessors
+HOOK: %unbox-byte-array cpu ( dst src -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
+
+HOOK: %unbox-f cpu ( dst src -- )
+
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
+
+HOOK: %box-alien cpu ( dst src -- )
+
+! GC check
+HOOK: %gc cpu ( -- )
+
+SYMBOL: operands
+
+: init-intrinsic ( insn -- )
+ [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
+
+: (operand) ( name -- operand )
+ operands get at* [ "Bad operand name" throw ] unless ;
+
+: operand ( name -- operand )
+ (operand) v>operand ;
+
+: operand-class ( var -- class )
+ (operand) value-class ;
+
+: operand-tag ( operand -- tag/f )
+ operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+ operand-class immediate class<= ;
+
+: unique-operands ( operands quot -- )
+ >r [ operand ] map prune r> each ; inline
diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor
index fabdaa7ff3..73fc81bd00 100644
--- a/unfinished/compiler/backend/x86/32/32.factor
+++ b/unfinished/compiler/backend/x86/32/32.factor
@@ -1,11 +1,318 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.cfg.registers
-compiler.backend ;
+USING: alien.c-types arrays kernel kernel.private math
+namespaces sequences stack-checker.known-words system layouts
+combinators command-line io vocabs.loader accessors init
+compiler compiler.units compiler.constants compiler.codegen
+compiler.cfg.builder compiler.alien compiler.codegen.fixup
+cpu.x86 compiler.backend compiler.backend.x86 ;
IN: compiler.backend.x86.32
+! We implement the FFI for Linux, OS X and Windows all at once.
+! OS X requires that the stack be 16-byte aligned, and we do
+! this on all platforms, sacrificing some stack space for
+! code simplicity.
+
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
{ double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
+
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
+
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+
+M: x86.32 struct-small-enough? ( size -- ? )
+ heap-size { 1 2 4 8 } member?
+ os { linux netbsd solaris } member? not and ;
+
+! On x86, parameters are never passed in registers.
+M: int-regs return-reg drop EAX ;
+M: int-regs param-regs drop { } ;
+M: int-regs push-return-reg return-reg PUSH ;
+: load/store-int-return ( n reg-class -- src dst )
+ return-reg stack-reg rot [+] ;
+M: int-regs load-return-reg load/store-int-return MOV ;
+M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: float-regs param-regs drop { } ;
+
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
+
+M: float-regs push-return-reg
+ stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
+
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
+
+: load/store-float-return ( n reg-class -- op size )
+ [ stack@ ] [ reg-size ] bi* ;
+M: float-regs load-return-reg load/store-float-return FLD ;
+M: float-regs store-return-reg load/store-float-return FSTP ;
+
+: align-sub ( n -- )
+ dup 16 align swap - ESP swap SUB ;
+
+: align-add ( n -- )
+ 16 align ESP swap ADD ;
+
+: with-aligned-stack ( n quot -- )
+ swap dup align-sub slip align-add ; inline
+
+M: x86.32 fixnum>slot@ 1 SHR ;
+
+M: x86.32 prepare-division CDQ ;
+
+M: x86.32 load-indirect
+ 0 [] MOV rc-absolute-cell rel-literal ;
+
+M: object %load-param-reg 3drop ;
+
+M: object %save-param-reg 3drop ;
+
+: box@ ( n reg-class -- stack@ )
+ #! Used for callbacks; we want to box the values given to
+ #! us by the C function caller. Computes stack location of
+ #! nth parameter; note that we must go back one more stack
+ #! frame, since %box sets one up to call the one-arg boxer
+ #! function. The size of this stack frame so far depends on
+ #! the reg-class of the boxer's arg.
+ reg-size neg + stack-frame* + 20 + ;
+
+: (%box) ( n reg-class -- )
+ #! If n is f, push the return register onto the stack; we
+ #! are boxing a return value of a C function. If n is an
+ #! integer, push [ESP+n] on the stack; we are boxing a
+ #! parameter being passed to a callback from C.
+ over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
+ push-return-reg ;
+
+M: x86.32 %box ( n reg-class func -- )
+ over reg-size [
+ >r (%box) r> f %alien-invoke
+ ] with-aligned-stack ;
+
+: (%box-long-long) ( n -- )
+ #! If n is f, push the return registers onto the stack; we
+ #! are boxing a return value of a C function. If n is an
+ #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
+ #! boxing a parameter being passed to a callback from C.
+ [
+ int-regs box@
+ EDX over stack@ MOV
+ EAX swap cell - stack@ MOV
+ ] when*
+ EDX PUSH
+ EAX PUSH ;
+
+M: x86.32 %box-long-long ( n func -- )
+ 8 [
+ [ (%box-long-long) ] [ f %alien-invoke ] bi*
+ ] with-aligned-stack ;
+
+: struct-return@ ( size n -- n )
+ [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.32 %box-large-struct ( n c-type -- )
+ ! Compute destination address
+ heap-size
+ [ swap struct-return@ ] keep
+ ECX ESP roll [+] LEA
+ 8 [
+ ! Push struct size
+ PUSH
+ ! Push destination address
+ ECX PUSH
+ ! Copy the struct from the C stack
+ "box_value_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-box-struct ( size -- )
+ ! Compute target address for value struct return
+ EAX ESP rot f struct-return@ [+] LEA
+ ! Store it as the first parameter
+ ESP [] EAX MOV ;
+
+M: x86.32 %box-small-struct ( c-type -- )
+ #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
+ 12 [
+ heap-size PUSH
+ EDX PUSH
+ EAX PUSH
+ "box_small_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-unbox ( -- )
+ #! Move top of data stack to EAX.
+ EAX ESI [] MOV
+ ESI 4 SUB ;
+
+: (%unbox) ( func -- )
+ 4 [
+ ! Push parameter
+ EAX PUSH
+ ! Call the unboxer
+ f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %unbox ( n reg-class func -- )
+ #! The value being unboxed must already be in EAX.
+ #! If n is f, we're unboxing a return value about to be
+ #! returned by the callback. Otherwise, we're unboxing
+ #! a parameter to a C function about to be called.
+ (%unbox)
+ ! Store the return value on the C stack
+ over [ store-return-reg ] [ 2drop ] if ;
+
+M: x86.32 %unbox-long-long ( n func -- )
+ (%unbox)
+ ! Store the return value on the C stack
+ [
+ dup stack@ EAX MOV
+ cell + stack@ EDX MOV
+ ] when* ;
+
+: %unbox-struct-1 ( -- )
+ #! Alien must be in EAX.
+ 4 [
+ EAX PUSH
+ "alien_offset" f %alien-invoke
+ ! Load first cell
+ EAX EAX [] MOV
+ ] with-aligned-stack ;
+
+: %unbox-struct-2 ( -- )
+ #! Alien must be in EAX.
+ 4 [
+ EAX PUSH
+ "alien_offset" f %alien-invoke
+ ! Load second cell
+ EDX EAX 4 [+] MOV
+ ! Load first cell
+ EAX EAX [] MOV
+ ] with-aligned-stack ;
+
+M: x86 %unbox-small-struct ( size -- )
+ #! Alien must be in EAX.
+ heap-size cell align cell /i {
+ { 1 [ %unbox-struct-1 ] }
+ { 2 [ %unbox-struct-2 ] }
+ } case ;
+
+M: x86.32 %unbox-large-struct ( n c-type -- )
+ #! Alien must be in EAX.
+ heap-size
+ ! Compute destination address
+ ECX ESP roll [+] LEA
+ 12 [
+ ! Push struct size
+ PUSH
+ ! Push destination address
+ ECX PUSH
+ ! Push source address
+ EAX PUSH
+ ! Copy the struct to the stack
+ "to_value_struct" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ cell temp@ EAX MOV ;
+
+M: x86.32 %alien-indirect ( -- )
+ cell temp@ CALL ;
+
+M: x86.32 %alien-callback ( quot -- )
+ 4 [
+ EAX load-indirect
+ EAX PUSH
+ "c_to_factor" f %alien-invoke
+ ] with-aligned-stack ;
+
+M: x86.32 %callback-value ( ctype -- )
+ ! Align C stack
+ ESP 12 SUB
+ ! Save top of data stack
+ %prepare-unbox
+ EAX PUSH
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Place top of data stack in EAX
+ EAX POP
+ ! Restore C stack
+ ESP 12 ADD
+ ! Unbox EAX
+ unbox-return ;
+
+M: x86.32 %cleanup ( alien-node -- )
+ #! a) If we just called an stdcall function in Windows, it
+ #! cleaned up the stack frame for us. But we don't want that
+ #! so we 'undo' the cleanup since we do that in %epilogue.
+ #! b) If we just called a function returning a struct, we
+ #! have to fix ESP.
+ {
+ {
+ [ dup abi>> "stdcall" = ]
+ [ alien-stack-frame ESP swap SUB ]
+ } {
+ [ dup return>> large-struct? ]
+ [ drop EAX PUSH ]
+ }
+ [ drop ]
+ } cond ;
+
+M: x86.32 %unwind ( n -- ) RET ;
+
+os windows? [
+ cell "longlong" c-type (>>align)
+ cell "ulonglong" c-type (>>align)
+ 4 "double" c-type (>>align)
+] unless
+
+: (sse2?) ( -- ? ) "Intrinsic" throw ;
+
+<<
+
+\ (sse2?) [
+ { EAX EBX ECX EDX } [ PUSH ] each
+ EAX 1 MOV
+ CPUID
+ EDX 26 SHR
+ EDX 1 AND
+ { EAX EBX ECX EDX } [ POP ] each
+ JE
+] { } define-if-intrinsic
+
+\ (sse2?) { } { object } define-primitive
+
+>>
+
+: sse2? ( -- ? ) (sse2?) ;
+
+"-no-sse2" cli-args member? [
+ "Checking if your CPU supports SSE2..." print flush
+ [ optimized-recompile-hook ] recompile-hook [
+ [ sse2? ] compile-call
+ ] with-variable
+ [
+ " - yes" print
+ "compiler.backend.x86.sse2" require
+ [
+ sse2? [
+ "This image was built to use SSE2, which your CPU does not support." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] unless
+ ] "compiler.backend.x86" add-init-hook
+ ] [
+ " - no" print
+ ] if
+] unless
diff --git a/unfinished/compiler/backend/x86/64/64.factor b/unfinished/compiler/backend/x86/64/64.factor
index 9499995068..c8760e51b4 100644
--- a/unfinished/compiler/backend/x86/64/64.factor
+++ b/unfinished/compiler/backend/x86/64/64.factor
@@ -1,7 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.cfg.registers
-compiler.backend ;
+USING: accessors alien.c-types arrays kernel kernel.private math
+namespaces make sequences system layouts alien alien.accessors
+alien.structs slots splitting assocs combinators
+cpu.x86 compiler.codegen compiler.constants
+compiler.codegen.fixup compiler.cfg.registers compiler.backend
+compiler.backend.x86 compiler.backend.x86.sse2 ;
IN: compiler.backend.x86.64
M: x86.64 machine-registers
@@ -12,3 +16,211 @@ M: x86.64 machine-registers
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
+
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
+
+M: int-regs return-reg drop RAX ;
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs return-reg drop XMM0 ;
+
+M: float-regs param-regs
+ drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 fixnum>slot@ drop ;
+
+M: x86.64 prepare-division CQO ;
+
+M: x86.64 load-indirect ( literal reg -- )
+ 0 [] MOV rc-relative rel-literal ;
+
+M: stack-params %load-param-reg
+ drop
+ >r R11 swap stack@ MOV
+ r> stack@ R11 MOV ;
+
+M: stack-params %save-param-reg
+ >r stack-frame* + cell + swap r> %load-param-reg ;
+
+: with-return-regs ( quot -- )
+ [
+ V{ RDX RAX } clone int-regs set
+ V{ XMM1 XMM0 } clone float-regs set
+ call
+ ] with-scope ; inline
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+ fields>> [
+ [ type>> ] [ offset>> ] bi 2array
+ ] map ;
+
+: split-struct ( pairs -- seq )
+ [
+ [ 8 mod zero? [ t , ] when , ] assoc-each
+ ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+ struct-types&offset split-struct [
+ [ c-type c-type-reg-class ] map
+ int-regs swap member? "void*" "double" ? c-type
+ ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+ heap-size cell align
+ cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+ dup heap-size 16 > [
+ flatten-large-struct
+ ] [
+ flatten-small-struct
+ ] if ;
+
+M: x86.64 %prepare-unbox ( -- )
+ ! First parameter is top of stack
+ RDI R14 [] MOV
+ R14 cell SUB ;
+
+M: x86.64 %unbox ( n reg-class func -- )
+ ! Call the unboxer
+ f %alien-invoke
+ ! Store the return value on the C stack
+ over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: x86.64 %unbox-long-long ( n func -- )
+ int-regs swap %unbox ;
+
+: %unbox-struct-field ( c-type i -- )
+ ! Alien must be in RDI.
+ RDI swap cells [+] swap reg-class>> {
+ { int-regs [ int-regs get pop swap MOV ] }
+ { double-float-regs [ float-regs get pop swap MOVSD ] }
+ } case ;
+
+M: x86.64 %unbox-small-struct ( c-type -- )
+ ! Alien must be in RDI.
+ "alien_offset" f %alien-invoke
+ ! Move alien_offset() return value to RDI so that we don't
+ ! clobber it.
+ RDI RAX MOV
+ [
+ flatten-small-struct [ %unbox-struct-field ] each-index
+ ] with-return-regs ;
+
+M: x86.64 %unbox-large-struct ( n c-type -- )
+ ! Source is in RDI
+ heap-size
+ ! Load destination address
+ RSI RSP roll [+] LEA
+ ! Load structure size
+ RDX swap MOV
+ ! Copy the struct to the C stack
+ "to_value_struct" f %alien-invoke ;
+
+: load-return-value ( reg-class -- )
+ 0 over param-reg swap return-reg
+ 2dup eq? [ 2drop ] [ MOV ] if ;
+
+M: x86.64 %box ( n reg-class func -- )
+ rot [
+ rot [ 0 swap param-reg ] keep %load-param-reg
+ ] [
+ swap load-return-value
+ ] if*
+ f %alien-invoke ;
+
+M: x86.64 %box-long-long ( n func -- )
+ int-regs swap %box ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+ heap-size 2 cells <= ;
+
+: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+
+: %box-struct-field ( c-type i -- )
+ box-struct-field@ swap reg-class>> {
+ { int-regs [ int-regs get pop MOV ] }
+ { double-float-regs [ float-regs get pop MOVSD ] }
+ } case ;
+
+M: x86.64 %box-small-struct ( c-type -- )
+ #! Box a <= 16-byte struct.
+ [
+ [ flatten-small-struct [ %box-struct-field ] each-index ]
+ [ RDX swap heap-size MOV ] bi
+ RDI 0 box-struct-field@ MOV
+ RSI 1 box-struct-field@ MOV
+ "box_small_struct" f %alien-invoke
+ ] with-return-regs ;
+
+: struct-return@ ( size n -- n )
+ [ ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.64 %box-large-struct ( n c-type -- )
+ ! Struct size is parameter 2
+ heap-size
+ RSI over MOV
+ ! Compute destination address
+ swap struct-return@ RDI RSP rot [+] LEA
+ ! Copy the struct from the C stack
+ "box_value_struct" f %alien-invoke ;
+
+M: x86.64 %prepare-box-struct ( size -- )
+ ! Compute target address for value struct return
+ RAX RSP rot f struct-return@ [+] LEA
+ RSP 0 [+] RAX MOV ;
+
+M: x86.64 %prepare-var-args RAX RAX XOR ;
+
+M: x86.64 %alien-global
+ [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
+ R11 0 MOV
+ rc-absolute-cell rel-dlsym
+ R11 CALL ;
+
+M: x86.64 %prepare-alien-indirect ( -- )
+ "unbox_alien" f %alien-invoke
+ cell temp@ RAX MOV ;
+
+M: x86.64 %alien-indirect ( -- )
+ cell temp@ CALL ;
+
+M: x86.64 %alien-callback ( quot -- )
+ RDI load-indirect "c_to_factor" f %alien-invoke ;
+
+M: x86.64 %callback-value ( ctype -- )
+ ! Save top of data stack
+ %prepare-unbox
+ ! Put former top of data stack in RDI
+ cell temp@ RDI MOV
+ ! Restore data/call/retain stacks
+ "unnest_stacks" f %alien-invoke
+ ! Put former top of data stack in RDI
+ RDI cell temp@ MOV
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
+
+M: x86.64 %cleanup ( alien-node -- ) drop ;
+
+M: x86.64 %unwind ( n -- ) drop 0 RET ;
+
+USE: cpu.x86.intrinsics
+
+! On 64-bit systems, the result of reading 4 bytes from memory
+! is a fixnum.
+\ alien-unsigned-4 small-reg-32 define-unsigned-getter
+\ set-alien-unsigned-4 small-reg-32 define-setter
+
+\ alien-signed-4 small-reg-32 define-signed-getter
+\ set-alien-signed-4 small-reg-32 define-setter
diff --git a/unfinished/compiler/backend/x86/sse2/sse2.factor b/unfinished/compiler/backend/x86/sse2/sse2.factor
new file mode 100644
index 0000000000..2d82a7a368
--- /dev/null
+++ b/unfinished/compiler/backend/x86/sse2/sse2.factor
@@ -0,0 +1,110 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays generic kernel system
+kernel.private math math.private memory namespaces sequences
+words math.floats.private layouts quotations cpu.x86
+compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
+compiler.constants compiler.backend compiler.backend.x86 ;
+IN: compiler.backend.x86.sse2
+
+M: x86 %box-float ( dst src -- )
+ #! Only called by pentium4 backend, uses SSE2 instruction
+ #! dest is a loc or a vreg
+ float 16 [
+ 8 (object@) swap v>operand MOVSD
+ float %store-tagged
+ ] %allot ;
+
+M: x86 %unbox-float ( dst src -- )
+ [ v>operand ] bi@ float-offset [+] MOVSD ;
+
+: define-float-op ( word op -- )
+ [ "x" operand "y" operand ] swap suffix T{ template
+ { input { { float "x" } { float "y" } } }
+ { output { "x" } }
+ { gc t }
+ } define-intrinsic ;
+
+{
+ { float+ ADDSD }
+ { float- SUBSD }
+ { float* MULSD }
+ { float/f DIVSD }
+} [
+ first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+ [ "x" operand "y" operand UCOMISD ] swap suffix
+ { { float "x" } { float "y" } } define-if-intrinsic ;
+
+{
+ { float< JAE }
+ { float<= JA }
+ { float> JBE }
+ { float>= JB }
+ { float= JNE }
+} [
+ first2 define-float-jump
+] each
+
+\ float>fixnum [
+ "out" operand "in" operand CVTTSD2SI
+ "out" operand tag-bits get SHL
+] T{ template
+ { input { { float "in" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
+} define-intrinsic
+
+\ fixnum>float [
+ "in" operand %untag-fixnum
+ "out" operand "in" operand CVTSI2SD
+] T{ template
+ { input { { f "in" } } }
+ { scratch { { float "out" } } }
+ { output { "out" } }
+ { clobber { "in" } }
+ { gc t }
+} define-intrinsic
+
+: alien-float-get-template
+ T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { float "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+ } ;
+
+: alien-float-set-template
+ T{ template
+ { input {
+ { float "value" float }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "offset" } }
+ } ;
+
+: define-alien-float-intrinsics ( word get-quot word set-quot -- )
+ [ "value" operand swap %alien-accessor ] curry
+ alien-float-set-template
+ define-intrinsic
+ [ "value" operand swap %alien-accessor ] curry
+ alien-float-get-template
+ define-intrinsic ;
+
+\ alien-double
+[ MOVSD ]
+\ set-alien-double
+[ swap MOVSD ]
+define-alien-float-intrinsics
+
+\ alien-float
+[ dupd MOVSS dup CVTSS2SD ]
+\ set-alien-float
+[ swap dup dup CVTSD2SS MOVSS ]
+define-alien-float-intrinsics
diff --git a/unfinished/compiler/backend/x86/x86.factor b/unfinished/compiler/backend/x86/x86.factor
new file mode 100644
index 0000000000..1ef2ebfbc4
--- /dev/null
+++ b/unfinished/compiler/backend/x86/x86.factor
@@ -0,0 +1,755 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays alien.accessors
+compiler.backend kernel kernel.private math memory namespaces
+make sequences words system layouts combinators math.order
+math.private alien alien.c-types slots.private cpu.x86
+cpu.x86.private compiler.backend compiler.codegen.fixup
+compiler.constants compiler.intrinsics compiler.cfg.builder
+compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.templates ;
+IN: compiler.backend.x86
+
+M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
+M: word JMP (JMP) rel-word ;
+M: label JMP (JMP) label-fixup ;
+M: word CALL (CALL) rel-word ;
+M: label CALL (CALL) label-fixup ;
+M: word JUMPcc (JUMPcc) rel-word ;
+M: label JUMPcc (JUMPcc) label-fixup ;
+
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+M: ds-loc v>operand n>> ds-reg reg-stack ;
+M: rs-loc v>operand n>> rs-reg reg-stack ;
+
+M: int-regs %save-param-reg drop >r stack@ r> MOV ;
+M: int-regs %load-param-reg drop swap stack@ MOV ;
+
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+M: double-float-regs MOVSS/D drop MOVSD ;
+
+M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
+
+GENERIC: push-return-reg ( reg-class -- )
+GENERIC: load-return-reg ( stack@ reg-class -- )
+GENERIC: store-return-reg ( stack@ reg-class -- )
+
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+HOOK: fixnum>slot@ cpu ( op -- )
+
+HOOK: prepare-division cpu ( -- )
+
+M: f load-literal
+ v>operand \ f tag-number MOV drop ;
+
+M: fixnum load-literal
+ v>operand swap tag-fixnum MOV ;
+
+M: x86 stack-frame ( n -- i )
+ 3 cells + 16 align cell - ;
+
+: factor-area-size ( -- n ) 4 cells ;
+
+M: x86 %prologue ( n -- )
+ temp-reg-1 0 MOV rc-absolute-cell rel-this
+ dup cell + PUSH
+ temp-reg-1 PUSH
+ stack-reg swap 2 cells - SUB ;
+
+M: x86 %epilogue ( n -- )
+ stack-reg swap ADD ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M: x86 %prepare-alien-invoke
+ #! Save Factor stack pointers in case the C code calls a
+ #! callback which does a GC, which must reliably trace
+ #! all roots.
+ "stack_chain" f temp-reg-1 %alien-global
+ temp-reg-1 [] stack-reg MOV
+ temp-reg-1 [] cell SUB
+ temp-reg-1 2 cells [+] ds-reg MOV
+ temp-reg-1 3 cells [+] rs-reg MOV ;
+
+M: x86 %call ( label -- ) CALL ;
+
+M: x86 %jump-label ( label -- ) JMP ;
+
+M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
+
+M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
+
+: code-alignment ( -- n )
+ building get length dup cell align swap - ;
+
+: align-code ( n -- )
+ 0 <repetition> % ;
+
+M: x86 %dispatch ( -- )
+ ! Load jump table base. We use a temporary register
+ ! since on AMD64 we have to load a 64-bit immediate. On
+ ! x86, this is redundant.
+ ! Untag and multiply to get a jump table offset
+ temp-reg-1 fixnum>slot@
+ ! Add jump table base
+ temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
+ temp-reg-1 temp-reg-2 ADD
+ temp-reg-1 HEX: 7f [+] JMP
+ ! Fix up the displacement above
+ code-alignment dup bootstrap-cell 8 = 15 9 ? +
+ building get dup pop* push
+ align-code ;
+
+M: x86 %dispatch-label ( word -- )
+ 0 cell, rc-absolute-cell rel-word ;
+
+M: x86 %peek [ v>operand ] bi@ MOV ;
+
+M: x86 %replace swap %peek ;
+
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
+
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+
+M: x86 fp-shadows-int? ( -- ? ) f ;
+
+M: x86 value-structs? t ;
+
+M: x86 small-enough? ( n -- ? )
+ HEX: -80000000 HEX: 7fffffff between? ;
+
+: %untag ( reg -- ) tag-mask get bitnot AND ;
+
+: %untag-fixnum ( reg -- ) tag-bits get SAR ;
+
+: %tag-fixnum ( reg -- ) tag-bits get SHL ;
+
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
+
+M: x86 %return ( -- ) 0 %unwind ;
+
+! Alien intrinsics
+M: x86 %unbox-byte-array ( dst src -- )
+ [ v>operand ] bi@ byte-array-offset [+] LEA ;
+
+M: x86 %unbox-alien ( dst src -- )
+ [ v>operand ] bi@ alien-offset [+] MOV ;
+
+M: x86 %unbox-f ( dst src -- )
+ drop v>operand 0 MOV ;
+
+M: x86 %unbox-any-c-ptr ( dst src -- )
+ { "is-byte-array" "end" "start" } [ define-label ] each
+ ! Address is computed in ds-reg
+ ds-reg PUSH
+ ds-reg 0 MOV
+ ! Object is stored in ds-reg
+ rs-reg PUSH
+ rs-reg swap v>operand MOV
+ ! We come back here with displaced aliens
+ "start" resolve-label
+ ! Is the object f?
+ rs-reg \ f tag-number CMP
+ "end" get JE
+ ! Is the object an alien?
+ rs-reg header-offset [+] alien type-number tag-fixnum CMP
+ "is-byte-array" get JNE
+ ! If so, load the offset and add it to the address
+ ds-reg rs-reg alien-offset [+] ADD
+ ! Now recurse on the underlying alien
+ rs-reg rs-reg underlying-alien-offset [+] MOV
+ "start" get JMP
+ "is-byte-array" resolve-label
+ ! Add byte array address to address being computed
+ ds-reg rs-reg ADD
+ ! Add an offset to start of byte array's data
+ ds-reg byte-array-offset ADD
+ "end" resolve-label
+ ! Done, store address in destination register
+ v>operand ds-reg MOV
+ ! Restore rs-reg
+ rs-reg POP
+ ! Restore ds-reg
+ ds-reg POP ;
+
+: allot-reg ( -- reg )
+ #! We temporarily use the datastack register, since it won't
+ #! be accessed inside the quotation given to %allot in any
+ #! case.
+ ds-reg ;
+
+: (object@) ( n -- operand ) allot-reg swap [+] ;
+
+: object@ ( n -- operand ) cells (object@) ;
+
+: load-zone-ptr ( reg -- )
+ #! Load pointer to start of zone array
+ 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( -- )
+ allot-reg load-zone-ptr
+ allot-reg PUSH
+ allot-reg dup cell [+] MOV ;
+
+: inc-allot-ptr ( n -- )
+ allot-reg POP
+ allot-reg cell [+] swap 8 align ADD ;
+
+M: x86 %gc ( -- )
+ "end" define-label
+ temp-reg-1 load-zone-ptr
+ temp-reg-2 temp-reg-1 cell [+] MOV
+ temp-reg-2 1024 ADD
+ temp-reg-1 temp-reg-1 3 cells [+] MOV
+ temp-reg-2 temp-reg-1 CMP
+ "end" get JLE
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
+: store-header ( header -- )
+ 0 object@ swap type-number tag-fixnum MOV ;
+
+: %allot ( header size quot -- )
+ allot-reg PUSH
+ swap >r >r
+ load-allot-ptr
+ store-header
+ r> call
+ r> inc-allot-ptr
+ allot-reg POP ; inline
+
+: fresh-object drop ;
+
+: %store-tagged ( reg tag -- )
+ >r dup fresh-object v>operand r>
+ allot-reg swap tag-number OR
+ allot-reg MOV ;
+
+: %allot-bignum-signed-1 ( outreg inreg -- )
+ #! on entry, inreg is a signed 32-bit quantity
+ #! exits with tagged ptr to bignum in outreg
+ #! 1 cell header, 1 cell length, 1 cell sign, + digits
+ #! length is the # of digits + sign
+ [
+ { "end" "nonzero" "positive" "store" }
+ [ define-label ] each
+ dup v>operand 0 CMP ! is it zero?
+ "nonzero" get JNE
+ 0 >bignum pick v>operand load-indirect ! this is our result
+ "end" get JMP
+ "nonzero" resolve-label
+ bignum 4 cells [
+ ! Write length
+ 1 object@ 2 v>operand MOV
+ ! Test sign
+ dup v>operand 0 CMP
+ "positive" get JGE
+ 2 object@ 1 MOV ! negative sign
+ dup v>operand NEG
+ "store" get JMP
+ "positive" resolve-label
+ 2 object@ 0 MOV ! positive sign
+ "store" resolve-label
+ 3 object@ swap v>operand MOV
+ ! Store tagged ptr in reg
+ bignum %store-tagged
+ ] %allot
+ "end" resolve-label
+ ] with-scope ;
+
+M: x86 %box-alien ( dst src -- )
+ [
+ { "end" "f" } [ define-label ] each
+ dup v>operand 0 CMP
+ "f" get JE
+ alien 4 cells [
+ 1 object@ \ f tag-number MOV
+ 2 object@ \ f tag-number MOV
+ ! Store src in alien-offset slot
+ 3 object@ swap v>operand MOV
+ ! Store tagged ptr in dst
+ dup object %store-tagged
+ ] %allot
+ "end" get JMP
+ "f" resolve-label
+ f [ v>operand ] bi@ MOV
+ "end" resolve-label
+ ] with-scope ;
+
+! Type checks
+\ tag [
+ "in" operand tag-mask get AND
+ "in" operand %tag-fixnum
+] T{ template
+ { input { { f "in" } } }
+ { output { "in" } }
+} define-intrinsic
+
+! Slots
+: %slot-literal-known-tag ( -- op )
+ "obj" operand
+ "n" get cells
+ "obj" operand-tag - [+] ;
+
+: %slot-literal-any-tag ( -- op )
+ "obj" operand %untag
+ "obj" operand "n" get cells [+] ;
+
+: %slot-any ( -- op )
+ "obj" operand %untag
+ "n" operand fixnum>slot@
+ "obj" operand "n" operand [+] ;
+
+\ slot {
+ ! Slot number is literal and the tag is known
+ {
+ [ "val" operand %slot-literal-known-tag MOV ] T{ template
+ { input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
+ { scratch { { f "val" } } }
+ { output { "val" } }
+ }
+ }
+ ! Slot number is literal
+ {
+ [ "obj" operand %slot-literal-any-tag MOV ] T{ template
+ { input { { f "obj" } { [ small-slot? ] "n" } } }
+ { output { "obj" } }
+ }
+ }
+ ! Slot number in a register
+ {
+ [ "obj" operand %slot-any MOV ] T{ template
+ { input { { f "obj" } { f "n" } } }
+ { output { "obj" } }
+ { clobber { "n" } }
+ }
+ }
+} define-intrinsics
+
+: generate-write-barrier ( -- )
+ #! Mark the card pointed to by vreg.
+ "val" operand-immediate? "obj" fresh-object? or [
+ ! Mark the card
+ "obj" operand card-bits SHR
+ "cards_offset" f "scratch" operand %alien-global
+ "scratch" operand "obj" operand [+] card-mark <byte> MOV
+
+ ! Mark the card deck
+ "obj" operand deck-bits card-bits - SHR
+ "decks_offset" f "scratch" operand %alien-global
+ "scratch" operand "obj" operand [+] card-mark <byte> MOV
+ ] unless ;
+
+\ set-slot {
+ ! Slot number is literal and the tag is known
+ {
+ [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
+ { input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" } }
+ }
+ }
+ ! Slot number is literal
+ {
+ [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
+ { input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" } }
+ }
+ }
+ ! Slot number in a register
+ {
+ [ %slot-any "val" operand MOV generate-write-barrier ] T{ template
+ { input { { f "val" } { f "obj" } { f "n" } } }
+ { scratch { { f "scratch" } } }
+ { clobber { "obj" "n" } }
+ }
+ }
+} define-intrinsics
+
+! Sometimes, we need to do stuff with operands which are
+! less than the word size. Instead of teaching the register
+! allocator about the different sized registers, with all
+! the complexity this entails, we just push/pop a register
+! which is guaranteed to be unused (the tempreg)
+: small-reg cell 8 = RBX EBX ? ; inline
+: small-reg-8 BL ; inline
+: small-reg-16 BX ; inline
+: small-reg-32 EBX ; inline
+
+! Fixnums
+: fixnum-op ( op hash -- pair )
+ >r [ "x" operand "y" operand ] swap suffix r> 2array ;
+
+: fixnum-value-op ( op -- pair )
+ T{ template
+ { input { { f "x" } { [ small-tagged? ] "y" } } }
+ { output { "x" } }
+ } fixnum-op ;
+
+: fixnum-register-op ( op -- pair )
+ T{ template
+ { input { { f "x" } { f "y" } } }
+ { output { "x" } }
+ } fixnum-op ;
+
+: define-fixnum-op ( word op -- )
+ [ fixnum-value-op ] keep fixnum-register-op
+ 2array define-intrinsics ;
+
+{
+ { fixnum+fast ADD }
+ { fixnum-fast SUB }
+ { fixnum-bitand AND }
+ { fixnum-bitor OR }
+ { fixnum-bitxor XOR }
+} [
+ first2 define-fixnum-op
+] each
+
+\ fixnum-bitnot [
+ "x" operand NOT
+ "x" operand tag-mask get XOR
+] T{ template
+ { input { { f "x" } } }
+ { output { "x" } }
+} define-intrinsic
+
+\ fixnum*fast {
+ {
+ [
+ "x" operand "y" get IMUL2
+ ] T{ template
+ { input { { f "x" } { [ small-tagged? ] "y" } } }
+ { output { "x" } }
+ }
+ } {
+ [
+ "out" operand "x" operand MOV
+ "out" operand %untag-fixnum
+ "y" operand "out" operand IMUL2
+ ] T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "out" } } }
+ { output { "out" } }
+ }
+ }
+} define-intrinsics
+
+: %untag-fixnums ( seq -- )
+ [ %untag-fixnum ] unique-operands ;
+
+\ fixnum-shift-fast [
+ "x" operand "y" get
+ dup 0 < [ neg SAR ] [ SHL ] if
+ ! Mask off low bits
+ "x" operand %untag
+] T{ template
+ { input { { f "x" } { [ ] "y" } } }
+ { output { "x" } }
+} define-intrinsic
+
+: overflow-check ( word -- )
+ "end" define-label
+ "z" operand "x" operand MOV
+ "z" operand "y" operand pick execute
+ ! If the previous arithmetic operation overflowed, then we
+ ! turn the result into a bignum and leave it in EAX.
+ "end" get JNO
+ ! There was an overflow. Recompute the original operand.
+ { "y" "x" } %untag-fixnums
+ "x" operand "y" operand rot execute
+ "z" get "x" get %allot-bignum-signed-1
+ "end" resolve-label ; inline
+
+: overflow-template ( word insn -- )
+ [ overflow-check ] curry T{ template
+ { input { { f "x" } { f "y" } } }
+ { scratch { { f "z" } } }
+ { output { "z" } }
+ { clobber { "x" "y" } }
+ { gc t }
+ } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+: fixnum-jump ( op inputs -- pair )
+ >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
+
+: fixnum-value-jump ( op -- pair )
+ { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
+
+: fixnum-register-jump ( op -- pair )
+ { { f "x" } { f "y" } } fixnum-jump ;
+
+: define-fixnum-jump ( word op -- )
+ [ fixnum-value-jump ] keep fixnum-register-jump
+ 2array define-if-intrinsics ;
+
+{
+ { fixnum< JL }
+ { fixnum<= JLE }
+ { fixnum> JG }
+ { fixnum>= JGE }
+ { eq? JE }
+} [
+ first2 define-fixnum-jump
+] each
+
+\ fixnum>bignum [
+ "x" operand %untag-fixnum
+ "x" get dup %allot-bignum-signed-1
+] T{ template
+ { input { { f "x" } } }
+ { output { "x" } }
+ { gc t }
+} define-intrinsic
+
+\ bignum>fixnum [
+ "nonzero" define-label
+ "positive" define-label
+ "end" define-label
+ "x" operand %untag
+ "y" operand "x" operand cell [+] MOV
+ ! if the length is 1, its just the sign and nothing else,
+ ! so output 0
+ "y" operand 1 v>operand CMP
+ "nonzero" get JNE
+ "y" operand 0 MOV
+ "end" get JMP
+ "nonzero" resolve-label
+ ! load the value
+ "y" operand "x" operand 3 cells [+] MOV
+ ! load the sign
+ "x" operand "x" operand 2 cells [+] MOV
+ ! is the sign negative?
+ "x" operand 0 CMP
+ "positive" get JE
+ "y" operand -1 IMUL2
+ "positive" resolve-label
+ "y" operand 3 SHL
+ "end" resolve-label
+] T{ template
+ { input { { f "x" } } }
+ { scratch { { f "y" } } }
+ { clobber { "x" } }
+ { output { "y" } }
+} define-intrinsic
+
+! User environment
+: %userenv ( -- )
+ "x" operand 0 MOV
+ "userenv" f rc-absolute-cell rel-dlsym
+ "n" operand fixnum>slot@
+ "n" operand "x" operand ADD ;
+
+\ getenv [
+ %userenv "n" operand dup [] MOV
+] T{ template
+ { input { { f "n" } } }
+ { scratch { { f "x" } } }
+ { output { "n" } }
+} define-intrinsic
+
+\ setenv [
+ %userenv "n" operand [] "val" operand MOV
+] T{ template
+ { input { { f "val" } { f "n" } } }
+ { scratch { { f "x" } } }
+ { clobber { "n" } }
+} define-intrinsic
+
+\ (tuple) [
+ tuple "layout" get size>> 2 + cells [
+ ! Store layout
+ "layout" get "scratch" operand load-indirect
+ 1 object@ "scratch" operand MOV
+ ! Store tagged ptr in reg
+ "tuple" get tuple %store-tagged
+ ] %allot
+] T{ template
+ { input { { [ ] "layout" } } }
+ { scratch { { f "tuple" } { f "scratch" } } }
+ { output { "tuple" } }
+ { gc t }
+} define-intrinsic
+
+\ (array) [
+ array "n" get 2 + cells [
+ ! Store length
+ 1 object@ "n" operand MOV
+ ! Store tagged ptr in reg
+ "array" get object %store-tagged
+ ] %allot
+] T{ template
+ { input { { [ ] "n" } } }
+ { scratch { { f "array" } } }
+ { output { "array" } }
+ { gc t }
+} define-intrinsic
+
+\ (byte-array) [
+ byte-array "n" get 2 cells + [
+ ! Store length
+ 1 object@ "n" operand MOV
+ ! Store tagged ptr in reg
+ "array" get object %store-tagged
+ ] %allot
+] T{ template
+ { input { { [ ] "n" } } }
+ { scratch { { f "array" } } }
+ { output { "array" } }
+ { gc t }
+} define-intrinsic
+
+\ <ratio> [
+ ratio 3 cells [
+ 1 object@ "numerator" operand MOV
+ 2 object@ "denominator" operand MOV
+ ! Store tagged ptr in reg
+ "ratio" get ratio %store-tagged
+ ] %allot
+] T{ template
+ { input { { f "numerator" } { f "denominator" } } }
+ { scratch { { f "ratio" } } }
+ { output { "ratio" } }
+ { gc t }
+} define-intrinsic
+
+\ <complex> [
+ complex 3 cells [
+ 1 object@ "real" operand MOV
+ 2 object@ "imaginary" operand MOV
+ ! Store tagged ptr in reg
+ "complex" get complex %store-tagged
+ ] %allot
+] T{ template
+ { input { { f "real" } { f "imaginary" } } }
+ { scratch { { f "complex" } } }
+ { output { "complex" } }
+ { gc t }
+} define-intrinsic
+
+\ <wrapper> [
+ wrapper 2 cells [
+ 1 object@ "obj" operand MOV
+ ! Store tagged ptr in reg
+ "wrapper" get object %store-tagged
+ ] %allot
+] T{ template
+ { input { { f "obj" } } }
+ { scratch { { f "wrapper" } } }
+ { output { "wrapper" } }
+ { gc t }
+} define-intrinsic
+
+! Alien intrinsics
+: %alien-accessor ( quot -- )
+ "offset" operand %untag-fixnum
+ "offset" operand "alien" operand ADD
+ "offset" operand [] swap call ; inline
+
+: %alien-integer-get ( quot reg -- )
+ small-reg PUSH
+ swap %alien-accessor
+ "value" operand small-reg MOV
+ "value" operand %tag-fixnum
+ small-reg POP ; inline
+
+: alien-integer-get-template
+ T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { f "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+ } ;
+
+: define-getter ( word quot reg -- )
+ [ %alien-integer-get ] 2curry
+ alien-integer-get-template
+ define-intrinsic ;
+
+: define-unsigned-getter ( word reg -- )
+ [ small-reg dup XOR MOV ] swap define-getter ;
+
+: define-signed-getter ( word reg -- )
+ [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
+
+: %alien-integer-set ( quot reg -- )
+ small-reg PUSH
+ small-reg "value" operand MOV
+ small-reg %untag-fixnum
+ swap %alien-accessor
+ small-reg POP ; inline
+
+: alien-integer-set-template
+ T{ template
+ { input {
+ { f "value" fixnum }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "value" "offset" } }
+ } ;
+
+: define-setter ( word reg -- )
+ [ swap MOV ] swap
+ [ %alien-integer-set ] 2curry
+ alien-integer-set-template
+ define-intrinsic ;
+
+\ alien-unsigned-1 small-reg-8 define-unsigned-getter
+\ set-alien-unsigned-1 small-reg-8 define-setter
+
+\ alien-signed-1 small-reg-8 define-signed-getter
+\ set-alien-signed-1 small-reg-8 define-setter
+
+\ alien-unsigned-2 small-reg-16 define-unsigned-getter
+\ set-alien-unsigned-2 small-reg-16 define-setter
+
+\ alien-signed-2 small-reg-16 define-signed-getter
+\ set-alien-signed-2 small-reg-16 define-setter
+
+\ alien-cell [
+ "value" operand [ MOV ] %alien-accessor
+] T{ template
+ { input {
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { scratch { { unboxed-alien "value" } } }
+ { output { "value" } }
+ { clobber { "offset" } }
+} define-intrinsic
+
+\ set-alien-cell [
+ "value" operand [ swap MOV ] %alien-accessor
+] T{ template
+ { input {
+ { unboxed-c-ptr "value" pinned-c-ptr }
+ { unboxed-c-ptr "alien" c-ptr }
+ { f "offset" fixnum }
+ } }
+ { clobber { "offset" } }
+} define-intrinsic
diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor
index f1199183d0..60dc5efdd9 100755
--- a/unfinished/compiler/cfg/builder/builder.factor
+++ b/unfinished/compiler/cfg/builder/builder.factor
@@ -32,18 +32,9 @@ IN: compiler.cfg.builder
: stop-iterating ( -- next ) end-basic-block f ;
-USE: qualified
-FROM: compiler.generator.registers => +input+ ;
-FROM: compiler.generator.registers => +output+ ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
SYMBOL: procedures
-
SYMBOL: current-word
-
SYMBOL: current-label
-
SYMBOL: loops
! Basic block after prologue, makes recursion faster
@@ -81,8 +72,8 @@ GENERIC: emit-node ( node -- next )
#! labelled by the current word, so that self-recursive
#! calls can skip an epilogue/prologue.
init-phantoms
- %prologue
- %branch
+ ##prologue
+ ##branch
begin-basic-block
current-label get remember-loop ;
@@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
[ emit-nodes ] with-node-iterator
] with-cfg-builder ;
-: build-cfg ( nodes word label -- procedures )
+: build-cfg ( nodes word -- procedures )
V{ } clone [
procedures [
- (build-cfg)
+ dup (build-cfg)
] with-variable
] keep ;
+SYMBOL: +intrinsics+
+SYMBOL: +if-intrinsics+
+
: if-intrinsics ( #call -- quot )
- word>> "if-intrinsics" word-prop ;
+ word>> +if-intrinsics+ word-prop ;
: local-recursive-call ( basic-block -- next )
- %branch
+ ##branch
basic-block get successors>> push
stop-iterating ;
: emit-call ( word -- next )
finalize-phantoms
{
- { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
+ { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
- [ %epilogue %jump stop-iterating ]
+ [ ##epilogue ##jump stop-iterating ]
} cond ;
! #recursive
@@ -130,50 +124,52 @@ M: #recursive emit-node
dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
! #if
-: emit-branch ( nodes -- final-bb )
- [
+: emit-branch ( obj quot -- final-bb )
+ '[
begin-basic-block copy-phantoms
- emit-nodes
- basic-block get dup [ %branch ] when
+ @
+ basic-block get dup [ ##branch ] when
] with-scope ;
-: emit-if ( node -- next )
- children>> [ emit-branch ] map
+: emit-branches ( seq quot -- )
+ '[ _ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each
- init-phantoms
- iterate-next ;
+ init-phantoms ;
+
+: emit-if ( node -- next )
+ children>> [ emit-nodes ] emit-branches ;
M: #if emit-node
- { { f "flag" } } lazy-load first %branch-t
- emit-if ;
+ { { f "flag" } } lazy-load first ##branch-t
+ emit-if iterate-next ;
! #dispatch
: dispatch-branch ( nodes word -- label )
+ #! The order here is important, dispatch-branches must
+ #! run after ##dispatch, so that each branch gets the
+ #! correct register state
gensym [
[
copy-phantoms
- %prologue
+ ##prologue
[ emit-nodes ] with-node-iterator
- %epilogue
- %return
+ ##epilogue
+ ##return
] with-cfg-builder
] keep ;
: dispatch-branches ( node -- )
children>> [
current-word get dispatch-branch
- %dispatch-label
+ ##dispatch-label
] each ;
: emit-dispatch ( node -- )
- %dispatch dispatch-branches init-phantoms ;
+ ##epilogue ##dispatch dispatch-branches init-phantoms ;
M: #dispatch emit-node
- #! The order here is important, dispatch-branches must
- #! run after %dispatch, so that each branch gets the
- #! correct register state
tail-call? [
emit-dispatch iterate-next
] [
@@ -187,23 +183,23 @@ M: #dispatch emit-node
! #call
: define-intrinsics ( word intrinsics -- )
- "intrinsics" set-word-prop ;
+ +intrinsics+ set-word-prop ;
: define-intrinsic ( word quot assoc -- )
2array 1array define-intrinsics ;
: define-if-intrinsics ( word intrinsics -- )
- [ +input+ associate ] assoc-map
- "if-intrinsics" set-word-prop ;
+ [ template new swap >>input ] assoc-map
+ +if-intrinsics+ set-word-prop ;
: define-if-intrinsic ( word quot inputs -- )
2array 1array define-if-intrinsics ;
: find-intrinsic ( #call -- pair/f )
- word>> "intrinsics" word-prop find-template ;
+ word>> +intrinsics+ word-prop find-template ;
: find-boolean-intrinsic ( #call -- pair/f )
- word>> "if-intrinsics" word-prop find-template ;
+ word>> +if-intrinsics+ word-prop find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ {
@@ -213,21 +209,24 @@ M: #dispatch emit-node
} cond ;
: do-if-intrinsic ( pair -- next )
- [ %if-intrinsic ] apply-template skip-next emit-if ;
+ [ ##if-intrinsic ] apply-template skip-next emit-if
+ iterate-next ;
: do-boolean-intrinsic ( pair -- next )
- [
- f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
- ] apply-template iterate-next ;
+ [ ##if-intrinsic ] apply-template
+ { t f } [
+ <constant> phantom-push finalize-phantoms
+ ] emit-branches
+ iterate-next ;
: do-intrinsic ( pair -- next )
- [ %intrinsic ] apply-template iterate-next ;
+ [ ##intrinsic ] apply-template iterate-next ;
-: setup-operand-classes ( #call -- )
- node-input-infos [ class>> ] map set-operand-classes ;
+: setup-value-classes ( #call -- )
+ node-input-infos [ class>> ] map set-value-classes ;
M: #call emit-node
- dup setup-operand-classes
+ dup setup-value-classes
dup find-if-intrinsic [ do-if-intrinsic ] [
dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
dup find-intrinsic [ do-intrinsic ] [
@@ -259,12 +258,12 @@ M: #r> emit-node
! #return
M: #return emit-node
- drop finalize-phantoms %epilogue %return f ;
+ drop finalize-phantoms ##epilogue ##return f ;
M: #return-recursive emit-node
finalize-phantoms
label>> id>> loops get key?
- [ %epilogue %return ] unless f ;
+ [ ##epilogue ##return ] unless f ;
! #terminate
M: #terminate emit-node drop stop-iterating ;
@@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
! FFI
M: #alien-invoke emit-node
params>>
- [ alien-invoke-frame %frame-required ]
- [ %alien-invoke iterate-next ]
+ [ alien-invoke-frame ##frame-required ]
+ [ ##alien-invoke iterate-next ]
bi ;
M: #alien-indirect emit-node
params>>
- [ alien-invoke-frame %frame-required ]
- [ %alien-indirect iterate-next ]
+ [ alien-invoke-frame ##frame-required ]
+ [ ##alien-indirect iterate-next ]
bi ;
M: #alien-callback emit-node
params>> dup xt>> dup
- [ init-phantoms %alien-callback ] with-cfg-builder
+ [ init-phantoms ##alien-callback ] with-cfg-builder
iterate-next ;
! No-op nodes
diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor
index 9acf0897b9..54b991bff1 100644
--- a/unfinished/compiler/cfg/cfg.factor
+++ b/unfinished/compiler/cfg/cfg.factor
@@ -11,16 +11,13 @@ C: <cfg> cfg
TUPLE: basic-block < identity-tuple
visited
number
-label
instructions
-successors
-predecessors ;
+successors ;
: <basic-block> ( -- basic-block )
basic-block new
V{ } clone >>instructions
- V{ } clone >>successors
- V{ } clone >>predecessors ;
+ V{ } clone >>successors ;
TUPLE: mr instructions word label ;
diff --git a/unfinished/compiler/cfg/debugger/debugger.factor b/unfinished/compiler/cfg/debugger/debugger.factor
index 65b0b97476..1da954c22e 100644
--- a/unfinished/compiler/cfg/debugger/debugger.factor
+++ b/unfinished/compiler/cfg/debugger/debugger.factor
@@ -9,11 +9,10 @@ IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
- build-tree optimize-tree gensym gensym build-cfg ;
+ build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
- [ build-tree-from-word nip optimize-tree ] keep dup
- build-cfg ;
+ [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor
index 5fd7608a4c..185dc1196a 100644
--- a/unfinished/compiler/cfg/instructions/instructions.factor
+++ b/unfinished/compiler/cfg/instructions/instructions.factor
@@ -6,103 +6,102 @@ IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
-TUPLE: %cond-branch < insn src ;
-TUPLE: %unary < insn dst src ;
-TUPLE: %nullary < insn dst ;
+TUPLE: ##cond-branch < insn src ;
+TUPLE: ##unary < insn dst src ;
+TUPLE: ##nullary < insn dst ;
! Stack operations
-INSN: %load-literal < %nullary obj ;
-INSN: %peek < %nullary loc ;
-INSN: %replace src loc ;
-INSN: %inc-d n ;
-INSN: %inc-r n ;
+INSN: ##load-literal < ##nullary obj ;
+INSN: ##peek < ##nullary loc ;
+INSN: ##replace src loc ;
+INSN: ##inc-d n ;
+INSN: ##inc-r n ;
! Calling convention
-INSN: %return ;
+INSN: ##return ;
! Subroutine calls
-INSN: %call word ;
-INSN: %jump word ;
-INSN: %intrinsic quot regs ;
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
-INSN: %dispatch-label label ;
-INSN: %dispatch ;
+INSN: ##dispatch-label label ;
+INSN: ##dispatch ;
! Boxing and unboxing
-INSN: %copy < %unary ;
-INSN: %copy-float < %unary ;
-INSN: %unbox-float < %unary ;
-INSN: %unbox-f < %unary ;
-INSN: %unbox-alien < %unary ;
-INSN: %unbox-byte-array < %unary ;
-INSN: %unbox-any-c-ptr < %unary ;
-INSN: %box-float < %unary ;
-INSN: %box-alien < %unary ;
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-f < ##unary ;
+INSN: ##unbox-alien < ##unary ;
+INSN: ##unbox-byte-array < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary ;
+INSN: ##box-float < ##unary ;
+INSN: ##box-alien < ##unary ;
-INSN: %gc ;
+INSN: ##gc ;
! FFI
-INSN: %alien-invoke params ;
-INSN: %alien-indirect params ;
-INSN: %alien-callback params ;
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: %nullary defs-vregs dst>> >vreg 1array ;
-M: %unary defs-vregs dst>> >vreg 1array ;
+M: ##nullary defs-vregs dst>> >vreg 1array ;
+M: ##unary defs-vregs dst>> >vreg 1array ;
M: insn defs-vregs drop f ;
-M: %replace uses-vregs src>> >vreg 1array ;
-M: %unary uses-vregs src>> >vreg 1array ;
+M: ##replace uses-vregs src>> >vreg 1array ;
+M: ##unary uses-vregs src>> >vreg 1array ;
M: insn uses-vregs drop f ;
-! M: %intrinsic uses-vregs vregs>> values ;
+: intrinsic-vregs ( assoc -- seq' )
+ [ nip >vreg ] { } assoc>map sift ;
+
+: intrinsic-defs-vregs ( insn -- seq )
+ defs-vregs>> intrinsic-vregs ;
+
+: intrinsic-uses-vregs ( insn -- seq )
+ uses-vregs>> intrinsic-vregs ;
+
+M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by CFG IR only.
-INSN: %prologue ;
-INSN: %epilogue ;
-INSN: %frame-required n ;
+INSN: ##prologue ;
+INSN: ##epilogue ;
+INSN: ##frame-required n ;
-INSN: %branch ;
-INSN: %branch-f < %cond-branch ;
-INSN: %branch-t < %cond-branch ;
-INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs dst ;
+INSN: ##branch ;
+INSN: ##branch-f < ##cond-branch ;
+INSN: ##branch-t < ##cond-branch ;
+INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
-M: %cond-branch uses-vregs src>> 1array ;
+M: ##cond-branch uses-vregs src>> >vreg 1array ;
-! M: %if-intrinsic uses-vregs vregs>> values ;
-
-M: %boolean-intrinsic defs-vregs dst>> 1array ;
-
-! M: %boolean-intrinsic uses-vregs
-! [ vregs>> values ] [ out>> ] bi suffix ;
+M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
INSN: _prologue n ;
INSN: _epilogue n ;
-TUPLE: label id ;
-
-INSN: _label label ;
-
-: <label> ( -- label ) \ <label> counter label boa ;
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- )
- dup label? [ get ] unless _label ;
+INSN: _label id ;
TUPLE: _cond-branch < insn src label ;
INSN: _branch label ;
INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot vregs ;
+INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
M: _cond-branch uses-vregs src>> >vreg 1array ;
-! M: _if-intrinsic uses-vregs vregs>> values ;
+
+M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
INSN: _spill src n ;
INSN: _reload dst n ;
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
index 00252e0c23..8f1378755d 100644
--- a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -3,6 +3,7 @@ USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
compiler.cfg.registers
+compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.debugger ;
@@ -98,3 +99,7 @@ SYMBOL: max-uses
[ ] [ 10 4 2 60 random-test ] unit-test
[ ] [ 10 20 2 400 random-test ] unit-test
[ ] [ 10 20 4 300 random-test ] unit-test
+
+USING: math.private compiler.cfg.debugger ;
+
+[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/unfinished/compiler/cfg/linear-scan/linear-scan.factor
index cbbb33b6c9..80737badc3 100644
--- a/unfinished/compiler/cfg/linear-scan/linear-scan.factor
+++ b/unfinished/compiler/cfg/linear-scan/linear-scan.factor
@@ -8,9 +8,20 @@ compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
IN: compiler.cfg.linear-scan
-! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+! References:
+
+! Linear Scan Register Allocation
+! by Massimiliano Poletto and Vivek Sarkar
+! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! Linear Scan Register Allocation for the Java HotSpot Client Compiler
+! by Christian Wimmer
! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
+! Quality and Speed in Linear-scan Register Allocation
+! by Omri Traub, Glenn Holloway, Michael D. Smith
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+
: linear-scan ( mr -- mr' )
[
dup compute-live-intervals
diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index d6ee979fe5..41b9895af2 100644
--- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -28,7 +28,6 @@ SYMBOL: live-intervals
at [ (>>end) ] [ uses>> push ] 2bi ;
: new-live-interval ( n vreg live-intervals -- )
- 2dup key? [ "Multiple defs" throw ] when
[ [ <live-interval> ] keep ] dip set-at ;
: compute-live-intervals* ( insn n -- )
diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor
index b1288fb301..fd21b5d3b6 100644
--- a/unfinished/compiler/cfg/linearization/linearization.factor
+++ b/unfinished/compiler/cfg/linearization/linearization.factor
@@ -12,7 +12,7 @@ IN: compiler.cfg.linearization
SYMBOL: frame-size
: compute-frame-size ( rpo -- )
- [ instructions>> [ %frame-required? ] filter ] map concat
+ [ instructions>> [ ##frame-required? ] filter ] map concat
[ f ] [ [ n>> ] map supremum ] if-empty
frame-size set ;
@@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
M: insn linearize-insn , drop ;
-M: %frame-required linearize-insn 2drop ;
+M: ##frame-required linearize-insn 2drop ;
-M: %prologue linearize-insn
+M: ##prologue linearize-insn
2drop frame-size get [ _prologue ] when* ;
-M: %epilogue linearize-insn
+M: ##epilogue linearize-insn
2drop frame-size get [ _epilogue ] when* ;
: useless-branch? ( basic-block successor -- ? )
@@ -39,50 +39,40 @@ M: %epilogue linearize-insn
: branch-to-return? ( successor -- ? )
#! A branch to a block containing just a return is cloned.
instructions>> dup length 2 = [
- [ first %epilogue? ] [ second %return? ] bi and
+ [ first ##epilogue? ] [ second ##return? ] bi and
] [ drop f ] if ;
: emit-branch ( basic-block successor -- )
{
{ [ 2dup useless-branch? ] [ 2drop ] }
{ [ dup branch-to-return? ] [ nip linearize-insns ] }
- [ nip label>> _branch ]
+ [ nip number>> _branch ]
} cond ;
-M: %branch linearize-insn
+M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: conditional ( basic-block -- basic-block successor1 label2 )
- dup successors>> first2 swap label>> ; inline
+ dup successors>> first2 swap number>> ; inline
: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
[ conditional ] [ src>> ] bi* swap ; inline
-M: %branch-f linearize-insn
+M: ##branch-f linearize-insn
boolean-conditional _branch-f emit-branch ;
-M: %branch-t linearize-insn
+M: ##branch-t linearize-insn
boolean-conditional _branch-t emit-branch ;
-M: %if-intrinsic linearize-insn
- [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
+: >intrinsic< ( insn -- quot defs uses )
+ [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
+
+M: ##if-intrinsic linearize-insn
+ [ conditional ] [ >intrinsic< ] bi*
_if-intrinsic emit-branch ;
-M: %boolean-intrinsic linearize-insn
- [
- "false" define-label
- "end" define-label
- "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
- dup dst>> t %load-literal
- "end" get _branch
- "false" resolve-label
- dup dst>> f %load-literal
- "end" resolve-label
- ] with-scope
- 2drop ;
-
: linearize-basic-block ( bb -- )
- [ label>> _label ] [ linearize-insns ] bi ;
+ [ number>> _label ] [ linearize-insns ] bi ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
diff --git a/unfinished/compiler/cfg/registers/registers.factor b/unfinished/compiler/cfg/registers/registers.factor
index 5eaed92072..ebc8382f0f 100644
--- a/unfinished/compiler/cfg/registers/registers.factor
+++ b/unfinished/compiler/cfg/registers/registers.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel ;
+USING: accessors namespaces math kernel alien classes ;
IN: compiler.cfg.registers
! Virtual CPU registers, used by CFG and machine IRs
@@ -8,8 +8,14 @@ IN: compiler.cfg.registers
MIXIN: value
GENERIC: >vreg ( obj -- vreg )
+GENERIC: set-value-class ( class obj -- )
+GENERIC: value-class* ( operand -- class )
+
+: value-class ( operand -- class ) value-class* object or ;
M: value >vreg drop f ;
+M: value set-value-class 2drop ;
+M: value value-class* drop f ;
! Register classes
SINGLETON: int-regs
@@ -47,6 +53,8 @@ INSTANCE: loc value
TUPLE: cached loc vreg ;
C: <cached> cached
+M: cached set-value-class vreg>> set-value-class ;
+M: cached value-class* vreg>> value-class* ;
M: cached >vreg vreg>> >vreg ;
INSTANCE: cached value
@@ -55,6 +63,8 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged ) f tagged boa ;
+M: tagged set-value-class (>>class) ;
+M: tagged value-class* class>> ;
M: tagged >vreg vreg>> ;
INSTANCE: tagged value
@@ -71,20 +81,30 @@ INSTANCE: unboxed value
TUPLE: unboxed-alien < unboxed ;
C: <unboxed-alien> unboxed-alien
+M: unboxed-alien value-class* drop simple-alien ;
+
! Untagged byte array pointer
TUPLE: unboxed-byte-array < unboxed ;
C: <unboxed-byte-array> unboxed-byte-array
+M: unboxed-byte-array value-class* drop c-ptr ;
+
! A register set to f
TUPLE: unboxed-f < unboxed ;
C: <unboxed-f> unboxed-f
+M: unboxed-f value-class* drop \ f ;
+
! An alien, byte array or f
TUPLE: unboxed-c-ptr < unboxed ;
C: <unboxed-c-ptr> unboxed-c-ptr
+M: unboxed-c-ptr value-class* drop c-ptr ;
+
! A constant value
TUPLE: constant value ;
C: <constant> constant
+M: constant value-class* value>> class ;
+
INSTANCE: constant value
diff --git a/unfinished/compiler/cfg/rpo/rpo.factor b/unfinished/compiler/cfg/rpo/rpo.factor
index 658bd5a29b..9fe6d3c90a 100644
--- a/unfinished/compiler/cfg/rpo/rpo.factor
+++ b/unfinished/compiler/cfg/rpo/rpo.factor
@@ -7,7 +7,6 @@ IN: compiler.cfg.rpo
: post-order-traversal ( basic-block -- )
dup visited>> [ drop ] [
t >>visited
- <label> >>label
[ successors>> [ post-order-traversal ] each ] [ , ] bi
] if ;
diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor
index 3cff5da37e..811ec5842f 100755
--- a/unfinished/compiler/cfg/stacks/stacks.factor
+++ b/unfinished/compiler/cfg/stacks/stacks.factor
@@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
SYMBOL: known-tag
! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
@@ -32,23 +30,19 @@ DEFER: %move
PRIVATE>
-: operand-class ( operand -- class )
- operand-class* object or ;
-
! Default implementation
-M: value set-operand-class 2drop ;
-M: value operand-class* drop f ;
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ;
+M: vreg value-class* reg-class>> value-class* ;
M: int-regs move-spec drop f ;
-M: int-regs operand-class* drop object ;
+M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ;
-M: float-regs operand-class* drop float ;
+M: float-regs value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
@@ -57,15 +51,13 @@ M: ds-loc live-loc?
M: rs-loc live-loc?
over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
+M: loc value-class* class>> ;
+M: loc set-value-class (>>class) ;
M: loc move-spec drop loc ;
M: f move-spec drop loc ;
-M: f operand-class* ;
+M: f value-class* ;
-M: cached set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
@@ -75,41 +67,34 @@ M: cached lazy-store
[ "live-locs" get at %move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
-M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
-M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
-M: constant operand-class* value>> class ;
M: constant move-spec class ;
! Moving values between locations and registers
: %move-bug ( -- * ) "Bug in generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
- dup operand-class {
- { [ dup \ f class<= ] [ drop %unbox-f ] }
- { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
- { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
- [ drop %unbox-any-c-ptr ]
+ dup value-class {
+ { [ dup \ f class<= ] [ drop ##unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+ [ drop ##unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
- int-regs next-vreg [ over %move operand-class ] keep
+ int-regs next-vreg [ over %move value-class ] keep
tagged new
swap >>vreg
swap >>class
@@ -117,28 +102,28 @@ M: constant move-spec class ;
: %move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
- { { f f } [ %copy ] }
- { { unboxed-alien unboxed-alien } [ %copy ] }
- { { unboxed-byte-array unboxed-byte-array } [ %copy ] }
- { { unboxed-f unboxed-f } [ %copy ] }
- { { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
- { { float float } [ %copy-float ] }
+ { { f f } [ ##copy ] }
+ { { unboxed-alien unboxed-alien } [ ##copy ] }
+ { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
+ { { unboxed-f unboxed-f } [ ##copy ] }
+ { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
+ { { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
- { { f constant } [ value>> %load-literal ] }
+ { { f constant } [ value>> ##load-literal ] }
- { { f float } [ %box-float ] }
- { { f unboxed-alien } [ %box-alien ] }
- { { f loc } [ %peek ] }
+ { { f float } [ ##box-float ] }
+ { { f unboxed-alien } [ ##box-alien ] }
+ { { f loc } [ ##peek ] }
- { { float f } [ %unbox-float ] }
- { { unboxed-alien f } [ %unbox-alien ] }
- { { unboxed-byte-array f } [ %unbox-byte-array ] }
- { { unboxed-f f } [ %unbox-f ] }
+ { { float f } [ ##unbox-float ] }
+ { { unboxed-alien f } [ ##unbox-alien ] }
+ { { unboxed-byte-array f } [ ##unbox-byte-array ] }
+ { { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
- { { loc f } [ swap %replace ] }
+ { { loc f } [ swap ##replace ] }
[ drop %move-via-temp ]
} case ;
@@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
- \ %inc-d (finalize-height) ;
+ \ ##inc-d (finalize-height) ;
TUPLE: phantom-retainstack < phantom-stack ;
@@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
M: phantom-retainstack finalize-height
- \ %inc-r (finalize-height) ;
+ \ ##inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack.
@@ -265,7 +250,7 @@ SYMBOL: fresh-objects
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
- alloc-vreg swap operand-class
+ alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
@@ -301,7 +286,7 @@ M: loc lazy-store
dup phantom-locs*
over stack>> [
dup constant? [ nip ] [
- operand-class over set-operand-class
+ value-class over set-value-class
] if
] 2map
over stack>> delete-all
@@ -330,10 +315,10 @@ M: loc lazy-store
: clear-phantoms ( -- )
[ stack>> delete-all ] each-phantom ;
-: set-operand-classes ( classes -- )
+: set-value-classes ( classes -- )
phantom-datastack get
over length over add-locs
- stack>> [ set-operand-class ] 2reverse-each ;
+ stack>> [ set-value-class ] 2reverse-each ;
: finalize-phantoms ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@@ -342,7 +327,7 @@ M: loc lazy-store
finalize-contents
clear-phantoms
finalize-heights
- fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+ fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
: fresh-object ( obj -- ) fresh-objects get push ;
@@ -358,14 +343,6 @@ M: loc lazy-store
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change ;
-: operand-tag ( operand -- tag/f )
- operand-class dup [ class-tag ] when ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: operand-immediate? ( operand -- ? )
- operand-class immediate class<= ;
-
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor
index 1be714afa5..a99102a9bb 100644
--- a/unfinished/compiler/cfg/templates/templates.factor
+++ b/unfinished/compiler/cfg/templates/templates.factor
@@ -5,16 +5,7 @@ quotations combinators classes.algebra compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stacks ;
IN: compiler.cfg.templates
-USE: qualified
-FROM: compiler.generator.registers => +input+ ;
-FROM: compiler.generator.registers => +output+ ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
-: template-input +input+ swap at ; inline
-: template-output +output+ swap at ; inline
-: template-scratch +scratch+ swap at ; inline
-: template-clobber +clobber+ swap at ; inline
+TUPLE: template input output scratch clobber gc ;
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
@@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
[ stack>> [ >vreg ] map sift ] each-phantom append ;
: clobbered ( template -- seq )
- [ template-output ] [ template-clobber ] bi append ;
+ [ output>> ] [ clobber>> ] bi append ;
: clobbered? ( value name -- ? )
\ clobbered get member? [
@@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
[
live-vregs \ live-vregs set
dup clobbered \ clobbered set
- template-input [ values ] [ lazy-load ] bi zip
+ input>> [ values ] [ lazy-load ] bi zip
] with-scope ;
: alloc-scratch ( template -- assoc )
- template-scratch [ swap alloc-vreg ] assoc-map ;
+ scratch>> [ swap alloc-vreg ] assoc-map ;
-: do-template-inputs ( template -- inputs )
+: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
#! registers.
- [ load-inputs ] [ alloc-scratch ] bi assoc-union ;
+ [ alloc-scratch ] [ load-inputs ] bi ;
-: do-template-outputs ( template inputs -- )
- [ template-output ] dip '[ _ at ] map
+: do-template-outputs ( template defs uses -- )
+ [ output>> ] 2dip assoc-union '[ _ at ] map
phantom-datastack get phantom-append ;
: apply-template ( pair quot -- vregs )
[
first2 dup do-template-inputs
- [ do-template-outputs ] keep
+ [ do-template-outputs ] 2keep
] dip call ; inline
: value-matches? ( value spec -- ? )
@@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
: spec-matches? ( value spec -- ? )
2dup first value-matches?
- >r >r operand-class 2 r> ?nth class-matches? r> and ;
+ >r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
- template-input phantom-datastack get swap
+ input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
: find-template ( templates -- pair/f )
diff --git a/unfinished/compiler/backend/alien/alien.factor b/unfinished/compiler/codegen/codegen.factor
similarity index 58%
rename from unfinished/compiler/backend/alien/alien.factor
rename to unfinished/compiler/codegen/codegen.factor
index 0c5a6afb75..ce2aa93fe6 100644
--- a/unfinished/compiler/backend/alien/alien.factor
+++ b/unfinished/compiler/codegen/codegen.factor
@@ -1,16 +1,128 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.backend.alien
+USING: namespaces make math math.parser sequences accessors
+kernel kernel.private layouts assocs words summary arrays
+threads continuations.private libc combinators
+alien alien.c-types alien.structs alien.strings
+compiler.errors
+compiler.alien
+compiler.backend
+compiler.codegen.fixup
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers ;
+IN: compiler.codegen
+
+GENERIC: generate-insn ( insn -- )
+
+: generate-insns ( insns -- code )
+ [
+ [
+ dup regs>> registers set
+ generate-insn
+ ] each
+ ] { } make fixup ;
+
+TUPLE: asm label code calls ;
+
+SYMBOL: calls
+
+: add-call ( word -- )
+ #! Compile this word later.
+ calls get push ;
+
+SYMBOL: compiling-word
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+! Mapping _label IDs to label instances
+SYMBOL: labels
+
+: init-generator ( word -- )
+ H{ } clone labels set
+ V{ } clone literal-table set
+ V{ } clone calls set
+ compiling-word set
+ compiled-stack-traces? compiling-word get f ? add-literal drop ;
+
+: generate ( mr -- asm )
+ [
+ [ label>> ]
+ [ word>> init-generator ]
+ [ instructions>> generate-insns ] tri
+ calls get
+ asm boa
+ ] with-scope ;
+
+: lookup-label ( id -- label )
+ labels get [ drop <label> ] cache ;
+
+M: _label generate-insn
+ id>> lookup-label , ;
+
+M: _prologue generate-insn
+ n>> %prologue ;
+
+M: _epilogue generate-insn
+ n>> %epilogue ;
+
+M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
+
+M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
+
+M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
+
+M: ##inc-d generate-insn n>> %inc-d ;
+
+M: ##inc-r generate-insn n>> %inc-r ;
+
+M: ##return generate-insn drop %return ;
+
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+
+M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+
+M: ##intrinsic generate-insn
+ [ init-intrinsic ] [ quot>> call ] bi ;
+
+M: _if-intrinsic generate-insn
+ [ init-intrinsic ]
+ [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
+
+M: _branch generate-insn
+ label>> lookup-label %jump-label ;
+
+M: _branch-f generate-insn
+ [ src>> ] [ label>> lookup-label ] bi %jump-f ;
+
+M: _branch-t generate-insn
+ [ src>> ] [ label>> lookup-label ] bi %jump-t ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn drop %dispatch ;
+
+M: ##copy generate-insn %copy ;
+
+M: ##copy-float generate-insn %copy-float ;
+
+M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
+
+M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
+
+M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
+
+M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
+
+M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
+
+M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
+
+M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
+
+M: ##gc generate-insn drop %gc ;
! #alien-invoke
-: set-stack-frame ( n -- )
- dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
- swap set-stack-frame
- call
- f set-stack-frame ; inline
-
GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
@@ -55,17 +167,17 @@ M: object reg-class-full?
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
-: (flatten-int-type) ( size -- )
- cell /i "void*" c-type <repetition> % ;
+: (flatten-int-type) ( size -- seq )
+ cell /i "void*" c-type <repetition> ;
-GENERIC: flatten-value-type ( type -- )
+GENERIC: flatten-value-type ( type -- types )
-M: object flatten-value-type , ;
+M: object flatten-value-type 1array ;
-M: struct-type flatten-value-type ( type -- )
+M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
-M: long-long-type flatten-value-type ( type -- )
+M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
[
0 [
c-type
- [ parameter-align (flatten-int-type) ] keep
+ [ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
- flatten-value-type
+ flatten-value-type %
] reduce drop
] { } make ;
@@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
-M: #alien-invoke generate-node
+M: ##alien-invoke generate-insn
params>>
- dup alien-invoke-frame [
- end-basic-block
- %prepare-alien-invoke
- dup objects>registers
- %prepare-var-args
- dup alien-invoke-dlsym %alien-invoke
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call function
+ dup alien-invoke-dlsym %alien-invoke
+ ! Box return value
+ dup %cleanup
+ box-return* ;
-! #alien-indirect
-M: #alien-indirect generate-node
+! ##alien-indirect
+M: ##alien-indirect generate-insn
params>>
- dup alien-invoke-frame [
- ! Flush registers
- end-basic-block
- ! Save registers for GC
- %prepare-alien-invoke
- ! Save alien at top of stack to temporary storage
- %prepare-alien-indirect
- dup objects>registers
- %prepare-var-args
- ! Call alien in temporary storage
- %alien-indirect
- dup %cleanup
- box-return*
- iterate-next
- ] with-stack-frame ;
+ ! Save registers for GC
+ %prepare-alien-invoke
+ ! Save alien at top of stack to temporary storage
+ %prepare-alien-indirect
+ ! Unbox parameters
+ dup objects>registers
+ %prepare-var-args
+ ! Call alien in temporary storage
+ %alien-indirect
+ ! Box return value
+ dup %cleanup
+ box-return* ;
-! #alien-callback
+! ##alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
@@ -264,18 +373,9 @@ TUPLE: callback-context ;
[ %unnest-stacks ] [ %callback-value ] if-void
callback-unwind %unwind ;
-: generate-callback ( params -- )
- dup xt>> dup [
- init-templates
- %prologue
- dup alien-stack-frame [
- [ registers>objects ]
- [ wrap-callback-quot %alien-callback ]
- [ %callback-return ]
- tri
- ] with-stack-frame
- ] with-cfg-builder ;
-
-M: #alien-callback generate-node
- end-basic-block
- params>> generate-callback iterate-next ;
+M: ##alien-callback generate-insn
+ params>>
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri ;
diff --git a/unfinished/compiler/codegen/fixup/fixup.factor b/unfinished/compiler/codegen/fixup/fixup.factor
index 1f1cf81cb9..5e8c1809a5 100755
--- a/unfinished/compiler/codegen/fixup/fixup.factor
+++ b/unfinished/compiler/codegen/fixup/fixup.factor
@@ -3,76 +3,20 @@
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private cpu.architecture
-math.order accessors growable ;
-IN: compiler.cfg.fixup
+combinators math.bitwise words.private math.order accessors
+growable compiler.constants compiler.backend ;
+IN: compiler.codegen.fixup
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: stack-frame-size ( code -- n )
- no-stack-frame [
- dup frame-required? [ n>> max ] [ drop ] if
- ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
+GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-
-M: label fixup*
- compiled-offset >>offset drop ;
-
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-: if-stack-frame ( frame-size quot -- )
- swap dup no-stack-frame =
- [ 2drop ] [ stack-frame swap call ] if ; inline
-
-M: word fixup*
- {
- { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
- } case ;
-
SYMBOL: relocation-table
SYMBOL: label-table
-! Relocation classes
-: rc-absolute-cell 0 ;
-: rc-absolute 1 ;
-: rc-relative 2 ;
-: rc-absolute-ppc-2/2 3 ;
-: rc-relative-ppc-2 4 ;
-: rc-relative-ppc-3 5 ;
-: rc-relative-arm-3 6 ;
-: rc-indirect-arm 7 ;
-: rc-indirect-arm-pc 8 ;
-
-: rc-absolute? ( n -- ? )
- dup rc-absolute-cell =
- over rc-absolute =
- rot rc-absolute-ppc-2/2 = or or ;
-
-! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym 1 ;
-: rt-literal 2 ;
-: rt-dispatch 3 ;
-: rt-xt 4 ;
-: rt-here 5 ;
-: rt-label 6 ;
-: rt-immediate 7 ;
+M: label fixup* compiled-offset >>offset drop ;
TUPLE: label-fixup label class ;
@@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- dup label>> swap class>> compiled-offset 4 - rot
+ [ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
@@ -97,8 +41,6 @@ M: rel-fixup fixup*
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
-M: frame-required fixup* drop ;
-
M: integer fixup* , ;
: adjoin* ( obj table -- n )
@@ -143,12 +85,11 @@ SYMBOL: literal-table
3array
] map concat ;
-: fixup ( code -- literals relocation labels code )
+: fixup ( fixup-directives -- code )
[
init-fixup
- dup stack-frame-size swap [ fixup* ] each drop
-
+ [ fixup* ] each
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
- ] { } make ;
+ ] { } make 4array ;
diff --git a/unfinished/compiler/new/new.factor b/unfinished/compiler/new/new.factor
new file mode 100644
index 0000000000..9b640b8d84
--- /dev/null
+++ b/unfinished/compiler/new/new.factor
@@ -0,0 +1,116 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.linear-scan
+compiler.codegen ;
+IN: compiler.new
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+ {
+ { [ dup "forgotten" word-prop ] [ ] }
+ { [ dup compiled get key? ] [ ] }
+ { [ dup inlined-block? ] [ ] }
+ { [ dup primitive? ] [ ] }
+ [ dup compile-queue get push-front ]
+ } cond drop ;
+
+: maybe-compile ( word -- )
+ dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: +failed+
+
+: ripple-up ( words -- )
+ dup "compiled-effect" word-prop +failed+ eq?
+ [ usage [ word? ] filter ] [ compiled-usage keys ] if
+ [ queue-compile ] each ;
+
+: ripple-up? ( word effect -- ? )
+ #! If the word has previously been compiled and had a
+ #! different stack effect, we have to recompile any callers.
+ swap "compiled-effect" word-prop [ = not ] keep and ;
+
+: save-effect ( word effect -- )
+ [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+ [ "compiled-effect" set-word-prop ]
+ 2bi ;
+
+: start ( word -- )
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
+ f swap compiler-error ;
+
+: fail ( word error -- )
+ [ swap compiler-error ]
+ [
+ drop
+ [ compiled-unxref ]
+ [ f swap compiled get set-at ]
+ [ +failed+ save-effect ]
+ tri
+ ] 2bi
+ return ;
+
+: frontend ( word -- effect nodes )
+ [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+: finish ( effect word -- )
+ [ swap save-effect ]
+ [ compiled-unxref ]
+ [
+ dup crossref?
+ [
+ dependencies get >alist
+ generic-dependencies get >alist
+ compiled-xref
+ ] [ drop ] if
+ ] tri ;
+
+: save-asm ( asm -- )
+ [ [ code>> ] [ label>> ] bi compiled get set-at ]
+ [ calls>> [ queue-compile ] each ]
+ bi ;
+
+: backend ( nodes word -- )
+ build-cfg [ build-mr linear-scan generate save-asm ] each ;
+
+: (compile) ( word -- )
+ '[
+ _ {
+ [ start ]
+ [ frontend ]
+ [ backend ]
+ [ finish ]
+ } cleave
+ ] with-return ;
+
+: compile-loop ( deque -- )
+ [ (compile) yield ] slurp-deque ;
+
+: decompile ( word -- )
+ f 2array 1array t modify-code-heap ;
+
+: optimized-recompile-hook ( words -- alist )
+ [
+ <hashed-dlist> compile-queue set
+ H{ } clone compiled set
+ [ queue-compile ] each
+ compile-queue get compile-loop
+ compiled get >alist
+ ] with-scope ;
+
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
+: recompile-all ( -- )
+ forget-errors all-words compile ;