toy-stack-compiler.red

Red []

forth: context [
prog: [1 2 3 4 5 6 7 8 '+ '+ '* 150 '+ '* '+ '* '*]

registers: ['eax 'ebx 'ecx 'edx]
register-taint: []		; registers we've touched in this set
register-goop: []		; registers we need to pop to use
register-sets: 0
next-register: head registers
value-positions: []
top-value: 0

alloc-reg: func [][
   ; add a new value, find a new register
   top-value: top-value + 1
   ret: first next-register
   ; start a new register set if we are losers
   unless ret [
      print "; new register set"
      next-register: head registers
      ret: first registers
      register-sets: register-sets + 1
      clear register-taint
      clear register-goop
   ]
   next-register: next next-register
   ; check for register taint
   if none? find register-taint ret [
      append register-taint ret
      print ['push ret]
   ]
   append value-positions ret
   ;print ["; values: " value-positions]
   ; return the lucky winner
   return ret
]

degoop: func[register][
   idx: find register-goop register
   if not none? idx [
      print ['pop register]
      idx/1: none
   ]
]

reg-top: func[][
   ; TODO ensure this is actually a register?
   first back tail value-positions
]

drop-top-reg: func[][
   ; perform the removal
   top-value: top-value - 1
   remove back tail value-positions
   ; check if we just flipped to a previous register set
   either head? next-register [
      print "; previous register set"
      register-sets: register-sets - 1
      next-register: back tail registers
      ; all registers have been tainted (by the previous set)
      clear register-taint
      append register-taint registers
      ; all registers have been gooped (by the set we just left)
      clear register-goop
      append register-goop registers
   ][
      next-register: back next-register
   ]
]

print [";" prog]

literal-op: [set literal integer! (
   lhs: alloc-reg
   print ['mov lhs literal "; value #" top-value]
   ;print ["; value positions:" value-positions]
)]

add-op: ['+ (
   ; grab operands
   rhs: reg-top
   degoop rhs
   drop-top-reg
   lhs: reg-top
   degoop lhs
   ; emit code, replace top value
   print ['add lhs rhs "; value #" top-value]
   ;print ["; values: " value-positions]
)]

mul-op: ['* (
   ; grab operands
   rhs: reg-top
   degoop rhs
   drop-top-reg
   lhs: reg-top
   degoop lhs
   ; emit code, replace top value
   print ['mul lhs rhs "; value #" top-value]
)]

op: [literal-op | mul-op | add-op]

machine: [some op]

parse prog machine
]

The stack is not aligned (more push than pop), is it intended ?