module GcodeMem(gcodeMem) where import Gcode import GcodeLow(gcodeNeed,primNeed,extra) import AssocTree import Util.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 (toEnum fun) GM na _ 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) {------------------------- DAVID ------------------------------- gMem za zs d at extra (gj@JUMPS_T:gs) = gMem' at [] gs where gMem' at ls (g@(JUMPTABLE l):gs) = gMem' (addZap at l (za,zs,d)) (g:ls) gs gMem' at ls gs = case gMem0 at extra gs of GM na ns h at gs -> gMem'' [] [] 0 at gs ls gMem'' na ns h at gs [] = GM na ns h at (gj:gs) gMem'' na ns h at gs ((JUMPTABLE l):ls) = case lookupAT at l of Just (na',ns',h',l',_) -> gMem'' (eitherOf na na') (eitherOf ns ns') (max h h') at (JUMPTABLE l':gs) ls Nothing -> error ("JUMPS_T couldn't find (na',ns',h') for " ++ show l) gMem za zs d at extra (gj@JUMPS_L:(JUMPLENGTH s gll):gs) = gMem' (addZap at gll (za,zs,d)) [] gs where gMem' at ls (g@(JUMPLIST v l):gs) = gMem' (addZap at l (za,zs,d)) (g:ls) gs gMem' at ls gs = case gMem0 at extra gs of GM na ns h at gs -> case lookupAT at gll of Just (na,ns,h,gll',_) -> gMem'' (JUMPLENGTH s gll') na ns h at gs ls Nothing -> error ("JUMPS_L couldn't find (na',ns',h') for gll " ++ show gll) gMem'' gl na ns h at gs [] = GM na ns h at (gj:gl:gs) gMem'' gl na ns h at gs ((JUMPLIST v l):ls) = case lookupAT at l of Just (na',ns',h',l',_) -> gMem'' gl (eitherOf na na') (eitherOf ns ns') (max h' h) at (JUMPLIST v l':gs) ls Nothing -> error ("JUMPS_L couldn't find (na',ns',h') for " ++ show l) ------------------------- DAVID ------------------ -} 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) {--------- DAVID ------------ gMem za zs d at extra (g@(MATCHCON):gs) = 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@(MATCHINT):gs) = case gMem za zs d at extra gs of GM na ns h at gs -> GM na (use d ns) h at (g:gs) ---------- DAVID ----------- -} 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 (<=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)