GcodeMem

module GcodeMem(gcodeMem) where

import Gcode
import GcodeLow(gcodeNeed,primNeed,extra)
import AssocTree
import Extra
import IntState
import Prim


gcodeMem prof state gcode = (fixOne state (if prof then extra else 0) gcode,state)

fixOne state extra [] = []
fixOne state extra (g@(STARTFUN pos fun):gs) =
  let arity = arityIS state fun
      GM na ns h _ gs' = gMem za zs 0 initAT (arity,extra) gs
      za = filter (`notElem` na) [1 .. arity]
      zs = [] -- There is no stack yet!
      zapins = map ZAP_ARG za
  in g: zapins ++ needheap h gs' 
fixOne state extra (g:gs) =
  g : fixOne state extra gs 


data GM =
    GM
	[Int]			-- need arg
	[Int]			-- need stack
	Int			-- Heap usage
	(AssocTree Int ([Int],[Int],Int,Int,Maybe Gcode)) -- Mapping from label to (need arg,need stack,heap usage,destiny)
	[Gcode]			-- Fixed gcode

eitherOf,bothOf:: [Int] -> [Int] -> [Int]
eitherOf  as bs = filter (`notElem` bs) as ++ bs
bothOf as bs = filter (`elem` bs) as 

needheap 0 gs = gs
needheap n (NEEDSTACK m:gs) = NEEDHEAP (n+m): gs	-- peephole opt /MW
needheap n gs = NEEDHEAP n : gs

use :: Int -> [Int] -> [Int]
use x xs = if x `elem` xs then xs else x : xs 

addZap :: AssocTree Int ([Int],[Int],Int) -> Int -> ([Int],[Int],Int) -> AssocTree Int ([Int],[Int],Int)
addZap  at label value = addAT at comb label value
 			 where comb (za,zs,d) (za',zs',d') =
				  (if d /= d' then strace ("Different depths for " ++ show label) else id) $
				  (bothOf za za',bothOf zs zs',d)

addNeed :: AssocTree Int ([Int],[Int],Int,Int,Maybe Gcode) -> Int -> ([Int],[Int],Int,Int,Maybe Gcode) -> AssocTree Int ([Int],[Int],Int,Int,Maybe Gcode)
addNeed at label value = addAT at (sndOf . strace ("redefinition of " ++ show label)) label value

maybeG (RETURN:_)      = Just RETURN
maybeG (RETURN_EVAL:_) = Just RETURN_EVAL
maybeG _               = Nothing

justG jg Nothing = jg
justG jg (Just g) = g


gMem0 :: AssocTree Int ([Int],[Int],Int) -> (Int,Int) -> [Gcode] -> GM
gMem0 at extra [] =  GM [] [] 0 initAT []
gMem0 at extra (g@(ALIGN_CONST):gs) =  GM [] [] 0 initAT (g:gs) -- only data declarations  
gMem0 at extra (g@(LABEL i):gs) = 
  case lookupAT at i of
    Nothing -> -- Unused label
       gMem0 at extra gs
    Just (za,zs,d) ->
      case gs of
	(JUMP j:gs)     -> case gMem0 (addZap at j (za,zs,d)) extra gs of
			     GM na ns h at gs ->
			       case lookupAT at j of
				Just (na,ns,h,j',mg) -> GM na ns h (addNeed at i (na,ns,h,j',mg)) gs
			  	Nothing -> error ("LABEL JUMP (in gMem0) couldn't find " ++ show j)
 	_               -> gMem za zs d at extra (g:gs)  -- Simplest to use code for the fall through case
gMem0 at extra (g:gs) =
  gMem0 at extra gs 

gMem :: [Int] -> [Int] -> Int -> AssocTree Int ([Int],[Int],Int) -> (Int,Int) -> [Gcode] -> GM
gMem za zs d at extra [] = GM [] [] 0 initAT []
gMem za zs d at extra (g@(ALIGN_CONST):gs) = GM [] [] 0 initAT (g:gs)
gMem za zs d at extra (g@RETURN:gs) =
  case gMem0 at extra gs of
    GM na ns h at gs -> GM na (use d ns) 0 at (g:gs)
gMem za zs d at extra (g@RETURN_EVAL:gs) =
  case gMem0 at extra gs of
    GM na ns h at gs -> GM na (use d ns) 0 at (g:gs)
gMem za zs d at extra (g@(SELECT i):gs) = -- SELECT now incorporates a RET_EVAL
  case gMem0 at extra gs of
    GM na ns h at gs -> GM na (use d ns) 0 at (g:gs)
gMem za zs d at extra (g@(LABEL i):gs) = -- fall through label
  case lookupAT at i of
    Nothing -> -- unused label, but fall through so skip only the label
       gMem za zs d at extra gs
    Just (za',zs',d') -> 
      case gMem (bothOf za' za) (bothOf zs' zs) d at extra gs of
        GM na ns h at gs -> GM na ns h (addNeed at i (na,ns,h,i,maybeG gs)) (g:gs)

gMem za zs d at extra (g@(JUMP i):gs) = 
  case gMem0 (addZap at i (za,zs,d)) extra gs of
    GM na ns h at gs ->
      case lookupAT at i of
	Just (na,ns,h,i',mg) ->
	  GM na ns h at (justG (JUMP i') mg:gs)
	Nothing -> error ("JUMP couldn't find " ++ show i)

gMem za zs d at extra (g@(JUMPFALSE i):gs) = 	-- DAVID
  let d' = d-1
  in case gMem za (filter (<=d') zs) d' (addZap at i (za,zs,d')) extra gs of
      GM na ns h at gs ->
        case lookupAT at i of
	  Just (na',ns',h',i',_) -> GM (eitherOf na' na) (eitherOf ns' ns) (max h' h) at (JUMPFALSE i':gs)				          -- DAVID
	  Nothing -> error ("JUMPFALSE couldn't find " ++ show i) -- DAVID


gMem za zs d at extra (TABLESWITCH size pad ls:gs)  =		  -- DAVID
    let nat = foldr (\l tr -> addZap tr l (za,zs,d)) at ls in
    case gMem0 nat extra gs of
        GM _ _ _ at gs ->
	    case gMem' at ls of
	        (na,ns,h,ls) ->
		    GM na ns h at (TABLESWITCH size pad ls:gs)
    where
        gMem' at [] =
	    ([],[],0,[])
        gMem' at (l:ls) =
	    let (na1,ns1,h1,ls1) = gMem' at ls  in 
            case lookupAT at l of
	    Just (na0,ns0,h0,l0,_) -> (eitherOf na0 na1, eitherOf ns0 ns1, 
                                       max h0 h1, l0:ls1)
	    Nothing -> error ("TABLESWITCH couldn't find " ++ show l)
						

gMem za zs d at extra (LOOKUPSWITCH size pad tls def:gs)  =	  -- DAVID
    let (tgs,ls) = unzip tls in
    let xls      = def : ls  in
    let nat      = foldr (\l tr -> addZap tr l (za,zs,d)) at xls in
    case gMem0 nat extra gs of
        GM _ _ _ at gs ->
	    case gMem' at xls of
		(na,ns,h,(def:ls)) ->
		    GM na ns h at (LOOKUPSWITCH size pad (zip tgs ls) def:gs)
    where
        gMem' at [] =
	    ([],[],0,[])
        gMem' at (l:ls) =
	    let (na1,ns1,h1,ls1) = gMem' at ls  in 
            case lookupAT at l of
	    Just (na0,ns0,h0,l0,_) -> (eitherOf na0 na1, eitherOf ns0 ns1, 
                                       max h0 h1, l0:ls1)
	    Nothing -> error ("LOOKUPSWITCH couldn't find " ++ show l)

gMem za zs d at extra (g@SELECTOR_EVAL:gs) =  -- ZAP (But we know that there is nothing to zap in a selector function!)
  case gMem za zs (d+1) at extra gs of
    GM na ns h at gs -> 
	GM (use 1 na) (filter (<= d) ns) 0 at (g:needheap h gs)

gMem za zs d at extra (g@EVAL:gs) = -- ZAP
  let GM na' ns' h' at' gs' = gMem (zaH++za) (zsH++zs) d at extra gs
      zsH = (filter (`notElem` zs) . filter (`notElem` ns')) [1 .. d-1]  -- EVAL uses top of stack
      zaH = (filter (`notElem` za) . filter (`notElem` na')) [1 .. fst extra] 
  in 
      GM na' (use d ns') 0 at' (map ZAP_ARG zaH ++ map (ZAP_STACK . (d-)) zsH ++ g:needheap h' gs')
gMem za zs d at extra (g@PRIMITIVE:gs)  = -- ZAP
  case gMem za zs (d+1) at extra gs of
    GM na ns h at gs ->
	GM [1 .. fst extra] (filter (<= d) ns) 0 at (g:needheap h gs)

gMem za zs d at extra (g@(PUSH_ARG i):gs) =
        case gMem za zs (d+1) at extra gs of
          GM na ns h at gs -> GM (use i na) (filter (<=d) ns) h at (g:gs)
--gMem za zs d at extra (g@(PUSH_ZAP_ARG i):gs) =	-- probably not needed
--        case gMem za zs (d+1) at extra gs of
--          GM na ns h at gs -> GM (use i na) (filter (&lt;=d) ns) h at (g:gs)
gMem za zs d at extra (g@(PUSH i):gs) =
        case gMem za zs (d+1) at extra gs of
          GM na ns h at gs -> GM na (use (d-i) (filter (<=d) ns)) h at (g:gs)
gMem za zs d at extra (g@(HEAP_ARG i):gs) =
        case gMem za zs d at extra gs of
          GM na ns h at gs -> GM (use i na) ns (h+1) at (g:gs)
--gMem za zs d at extra (g@(HEAP_ARG_ARG i j):gs) =	-- probably not needed
--        case gMem za zs d at extra gs of
--          GM na ns h at gs -> GM (use j (use i na)) ns (h+2) at (g:gs)
gMem za zs d at extra (g@(HEAP i):gs) =
        case gMem za zs d at extra gs of
          GM na ns h at gs -> GM na (use (d-i) ns) (h+1) at (g:gs)
gMem za zs d at extra (g@(SLIDE   i):gs) =
	let d' = d-i
        in case gMem za (filter (<=d') zs) d' at extra gs of
             GM na ns h at gs -> GM na (use d ns) h at (g:gs)
gMem za zs d at extra (g@(UNPACK i):gs) =
        case gMem za zs (d-1+i) at extra gs of
          GM na ns h at gs -> GM na (use d (filter (<=d) ns)) h at (g:gs)
--gMem za zs d at extra (g@(SELECT i):gs) = -- this clause now matched earlier
--        case gMem za zs d at extra gs of
--          GM na ns h at gs -> GM na (use d ns) h at (g:gs)
gMem za zs d at extra (g@(APPLY i):gs) = 
	let d' = d-i
        in case gMem za (filter (<=d') zs) d' at extra gs of
             GM na ns h at gs ->   
				GM na (eitherOf [d-i .. d] ns) (10+i*(3+snd extra)+h) -- Not always correct (10 is a large 
							          at (g:gs)            -- application but they can be larger)
gMem za zs d at extra (g@(PRIM prim):gs) = 
  case primNeed (snd extra) prim of
    (id,ih) ->
      if id == 0 then
        case gMem za zs d at extra gs of
          GM na ns h at gs -> GM na (use d ns) (h+ih) at (g:gs)
      else if id < 0 then
	let d' = d+id
        in case gMem za (filter (<=d') zs) d' at extra gs of
             GM na ns h at gs -> GM na (eitherOf [d+id .. d] ns) (h+ih) at (g:gs)
      else
	error ("gmem: primitive that increases the stack!" ++ strPrim prim)

gMem za zs d at extra (g:gs) = 
  case gcodeNeed (snd extra) g of
    (id,ih) ->
      if id == 0 then
        case gMem za zs d at extra gs of
          GM na ns h at gs -> GM na (use d ns) (h+ih) at (g:gs)
      else if id < 0 then
	let d' = d+id
        in case gMem za (filter (<=d') zs) d' at extra gs of
             GM na ns h at gs -> GM na (eitherOf [d+id .. d] ns) (h+ih) at (g:gs)
      else
        case gMem za zs (d+id) at extra gs of
          GM na ns h at gs -> GM na (filter (<=d) ns) (h+ih) at (g:gs)