Source

Toy C#-ish compiler / SSMOptimise.hs

module SSMOptimise where

import ParseLib.Abstract
import SSM
import ParseUtils (start)

-- Seeing as Code is just a list, we'll optimise it by parsing it and creating a
-- similar list.

p <++> q = (++) <$> p <*> q

getAjs = do
    x <- anySymbol
    case x of AJS y -> return y
              _ -> failp

getLabel = do
    x <- anySymbol
    case x of LABEL y -> return y
              _ -> failp

getBra = do
    x <- anySymbol
    case x of BRA y -> return y
              _ -> failp

getLink = do
    x <- anySymbol
    case x of LINK y -> return y
              _ -> failp

getLdla = do
    x <- anySymbol
    case x of LDLA y -> return y
              _ -> failp

getLds = do
    x <- anySymbol
    case x of LDS y -> return y
              _ -> failp

getLdc = do
    x <- anySymbol
    case x of LDC y -> return y
              _ -> failp

getStoreFunc = satisfy isStoreFunc

isJump (RET) = True
isJump (BRA _) = True
isJump HALT = True
isJump _ = False

isLabel (LABEL _) = True
isLabel _ = False

-- STA is not listed due to popping too much.
isStoreFunc (STS _) = True
isStoreFunc (STL _) = True
isStoreFunc (STR _) = True
isStoreFunc _ = False

anyAsList = (:[]) <$> anySymbol

makeOptimiser :: Parser s [s] -> Parser s [s]
makeOptimiser p = (p <|> anyAsList)
             <++> makeOptimiser p
              <|> [] <$ eof

mergeConsAjs = (\x y -> [AJS $ x + y])
           <$> getAjs
           <*> getAjs

dropNullAjs = (\x -> if x == 0 then [] else [AJS x])
          <$> getAjs

mergeAjsLink = (\x y -> [LINK $ x + y])
                <$> getLink
                <*> getAjs

optimiseAssignment = (\x y -> [x, AJS $ y+1])
                <$  symbol (LDS 0)
                <*> getStoreFunc
                <*> getAjs

optimiseEmptyElse = do
    x <- getBra
    y <- getLabel
    symbol $ LABEL x
    return [LABEL x, LABEL y]

mergeAjsUnlink = (:[]) <$ getAjs <*> symbol UNLINK

-- Can't be used at the moment because it destroys vtables.
removedeadCode = (:[])
             <$> satisfy isJump
              <* many (satisfy $ not . isLabel)

mergeLdlaSta = (\x -> [STL x])
           <$> getLdla
           <*  symbol (STA 0)

removeDoubleRet = [UNLINK, RET]
                <$ symbol UNLINK
                <* symbol RET
                <* symbol UNLINK
                <* symbol RET

removeEmptyBody = []
                <$ getLink
                <* symbol UNLINK

dropRedundantAdd = do
    c <- getLdc
    if c == 0 then symbol ADD <|> symbol SUB
    else failp
    return []

(-->) :: Parser s [s] -> Parser s [s] -> Parser s [s]
p --> q = start q . start p <$> many anySymbol

allOptimisers = foldl1 (-->) . map makeOptimiser $
    [dropRedundantAdd, mergeLdlaSta, optimiseAssignment, mergeAjsLink, mergeConsAjs,
    mergeAjsUnlink, dropNullAjs, optimiseEmptyElse, removeDoubleRet, removeEmptyBody]