module Main where import Monad import List import Maybe import Language.Haskell.Pretty import Language.Haskell.Syntax data Equation = Equation String [String] Expression data Expression = Let [Equation] Expression | Apply Expression Expression | Number Int | Variable String | Plus Expression Expression | Mul Expression Expression | Minus Expression Expression | Div Expression Expression | Case Expression [(Int, Expression)] Expression cLet::[Equation]->Expression->Expression cLet [] expr = expr cLet eqs expr = Let eqs expr nowhere::SrcLoc nowhere = SrcLoc "" 0 0 tre::Expression->HsExp tre (Let eqs expr) = HsLet (map trs eqs) (tre expr) tre (Apply f arg) = HsApp (tre f) (tre arg) tre (Number n) = HsLit (HsInt $ toInteger n) tre (Variable v) = HsVar $ UnQual $ HsIdent v tre (Plus e1 e2) = HsInfixApp (tre e1) (HsQVarOp $ UnQual $ HsSymbol "+") (tre e2) tre (Mul e1 e2) = HsInfixApp (tre e1) (HsQVarOp $ UnQual $ HsSymbol "*") (tre e2) tre (Minus e1 e2) = HsInfixApp (tre e1) (HsQVarOp $ UnQual $ HsSymbol "-") (tre e2) tre (Div e1 e2) = HsInfixApp (tre e1) (HsQVarOp $ UnQual $ HsIdent "div") (tre e2) tre (Case expr alts dflt) = HsCase (tre expr) (als ++ [dalt]) where dalt = HsAlt nowhere HsPWildCard (HsUnGuardedAlt $ tre dflt) [] als = map mkAlt alts mkAlt (n, exp) = HsAlt nowhere (HsPLit $ HsInt $ toInteger n) (HsUnGuardedAlt $ tre exp) [] trs::Equation->HsDecl trs (Equation name pars expr) = HsFunBind [HsMatch nowhere (HsIdent name) pat (HsUnGuardedRhs $ tre expr) []] where pat = map mkPat pars mkPat par = HsPVar (HsIdent par) instance Show Equation where show eq = prettyPrint $ trs eq showList eq x = x ++ (prettyPrint $ HsModule nowhere (Module "Main") Nothing [] (map trs eq)) instance Show Expression where show expr = prettyPrint $ tre expr eqName::Equation->String eqName (Equation name _ _) = name sampleProgram::[Equation] sampleProgram = [ Equation "mod" ["x", "y"] (Let [ Equation "p" [] (Div (Variable "x") (Variable "y")), Equation "s" [] (Mul (Variable "p") (Variable "y")) ] (Minus (Variable "x") (Variable "s"))), -- mod x y = let p = x `div` y -- s = p * y -- in x - s Equation "nsd" ["x", "y"] (Case (Variable "x") [(0, Variable "y")] (Let [ Equation "p" [] (Apply (Apply (Variable "mod") (Variable "y")) (Variable "x")) ] (Apply (Apply (Variable "nsd") (Variable "p")) (Variable "x")))) -- nsd x y = case x of -- 0 -> y -- _ -> let p = mod y x -- in nsd p x ] test::State test = compile sampleProgram (Apply (Apply (Variable "nsd") (Number 24)) (Number 36)) data Value = VNumber Int | VThunk Int [Int] deriving (Eq, Show) type Regs = [(Int,Int)] data State = State {stateCode::[(Int,String,Int,[Instruction])], stateData::[(Int,Value)], stateFree::Int, stateRegs::Regs, stateInsns::[Instruction], stateStack::[(Regs, [Int])]} showCode::(Int,String,Int,[Instruction])->String showCode (n,name,args,insns) = name ++ "(" ++ show n ++ "): " ++ show args ++ " args\n" ++ concatMap showInsn insns ++ "\n" where showInsn insn = " " ++ show insn ++ "\n" instance Show State where show state = concatMap showCode (stateCode state) emptyState::State emptyState=State {stateCode=[], stateData=[], stateFree=1, stateRegs=[], stateInsns=[], stateStack=[]} data Instruction = IMove Int Int | IPlus Int Int Int | IMinus Int Int Int | IMul Int Int Int | IDiv Int Int Int | IExecute Int | IReturn | ICExecute Int Int Int | ICall Int Int | ILoad Int Int | IApply Int Int Int | IRewrite Int Int deriving (Show) -- interpret interpret::State->Int interpret state | null insns = ret | otherwise = interpret $ executeInsn insn $ state {stateInsns = rest} where insns = stateInsns state VNumber ret = readValue state 0 (insn:rest) = insns getReg::State->Int->Int getReg state reg = fromJust $ lookup reg (stateRegs state) setReg::Int->Int->State->State setReg reg addr state = state {stateRegs = regs'} where regs = stateRegs state regs' = repl regs repl [] = [(reg, addr)] repl ((rg, add) : rest) | rg == reg = (rg, addr) : rest | otherwise = (rg, add) : repl rest readValue::State->Int->Value readValue state reg = fromJust $ lookup addr (stateData state) where addr = getReg state reg writeValue::Int->Value->State->State writeValue reg value state = state {stateData = dta} where addr = getReg state reg dta = (addr, value) : stateData state allocData::Int->State->State allocData reg state = setReg reg addr $ state {stateFree = addr + 1} where addr = stateFree state addInsns::[Instruction]->State->State addInsns insns state = state {stateInsns = insns ++ stateInsns state} getFunction::State->Int->(Int,String,[Instruction]) getFunction state fn = look fns where fns = stateCode state look ((f, name, n, i) : rest) | f == fn = (n, name, i) | otherwise = look rest loadArgs::[Int]->State->State loadArgs args state = foldl (\state (n, addr) -> setReg n addr state) state $ zip [1..] args pushState::[Int]->State->State pushState restArgs state = state {stateRegs = [], stateStack = stack'} where stack = stateStack state stack' = (filter (\(n,_) -> n /= 0) $ stateRegs state, restArgs) : stack popState::State->(State, [Int]) popState state = (state {stateRegs = (0, addr) : regs, stateStack = stack}, rest) where ((regs, rest) : stack) = stateStack state addr = getReg state 0 executeInsn::Instruction->State->State executeInsn (IMove from to) state = setReg to (getReg state from) state executeInsn (IPlus a b to) state = executeArith (+) a b to state executeInsn (IMinus a b to) state = executeArith (-) a b to state executeInsn (IMul a b to) state = executeArith (*) a b to state executeInsn (IDiv a b to) state = executeArith div a b to state executeInsn (IExecute reg) state = case value of VNumber _ -> setReg 0 (getReg state reg) state VThunk fn args -> executeExec fn args where value = readValue state reg executeExec fn args | nArgs < rArgs = setReg 0 (getReg state reg) state | otherwise = addInsns insns $ loadArgs args $ pushState rest state where nArgs = length args (rArgs, _, insns) = getFunction state fn (pass, rest) = splitAt rArgs args executeInsn IReturn state | null remArgs = addInsns [IExecute 0] state' | otherwise = addInsns [IExecute 0] state'' where (state', remArgs) = popState state VThunk fn args = readValue state' 0 state'' = writeValue 0 (VThunk fn (args ++ remArgs)) state' executeInsn (ICExecute a b w) state | readValue state a == readValue state b = addInsns [IExecute w] state | otherwise = state executeInsn (ICall fn reg) state = writeValue reg (VThunk fn []) $ allocData reg state executeInsn (ILoad n reg) state = writeValue reg (VNumber n) $ allocData reg state executeInsn (IApply fn par reg) state = writeValue reg nThunk $ allocData reg state where VThunk fnum args = readValue state fn nThunk = VThunk fnum (args ++ [getReg state par]) executeInsn (IRewrite what with) state = writeValue what (readValue state with) state executeArith::(Int->Int->Int)->Int->Int->Int->State->State executeArith op a b to state = writeValue to (VNumber rslt) $ allocData to state where VNumber va = readValue state a VNumber vb = readValue state b rslt = op va vb -- stav pri kompilaci data ECompileState = ECompileState {ecFreeReg::Int, -- prvni volny registr ecLocal::[(String, Int)], -- lokalni promenne ecFunctions::[(String, Int)], -- funkce ecState::State, -- stav ecCurFn::String} -- aktualne kompilovana fce deriving (Show) data TMonad a = TMonad (ECompileState -> (ECompileState, a)) instance Monad TMonad where TMonad f >>= g = TMonad h where h state = let (state1, x) = f state TMonad g' = g x in g' state1 return x = TMonad (\state -> (state, x)) getState::TMonad ECompileState getState = TMonad (\state -> (state, state)) setState::ECompileState->TMonad () setState state = TMonad (\_ -> (state, ())) curFN::TMonad String curFN = getState >>= return . ecCurFn setCurFN::String->TMonad () setCurFN name = getState >>= \s -> setState s{ecCurFn=name} runCompile::TMonad a -> State runCompile (TMonad f) = ecState ecSt where (ecSt, _) = f (ECompileState 1 [] [] emptyState "") -- zkompiluje program compile::[Equation]->Expression->State compile program expression = runCompile (doCompile program expression) doCompile::[Equation]->Expression->TMonad () doCompile program expression = do let program' = simplify $ Equation "main" [] (Let program expression) fnames = map eqName program' state <- getState setState state{ecFunctions = ("id", 1) : zip fnames [2..]} compileEquation $ Equation "id" ["x"] (Variable "x") mapM compileEquation program' newECState [] code <- compileExpression (Variable "main") 0 state <- getState let ecSt = ecState state setState state{ecState = ecSt {stateInsns=code}} -- pripravi stav pro kompilaci vyrazu newECState::[String]->TMonad () newECState params = do state <- getState setState state{ecFreeReg = 1, ecLocal = []} bind params -- zkompiluje jednu rovnost programu a prislusny kod prida k pocatecnimu stavu compileEquation::Equation->TMonad () compileEquation (Equation fc params expr) = do Just place <- findGlobal fc setCurFN fc newECState params exprCode <- compileExpression expr 0 state <- getState let ecSt = ecState state mCode' = (place, fc, length params, exprCode ++ [IReturn]) : stateCode ecSt setState state{ecState = ecSt {stateCode = mCode'}} -- zkompiluje zadany vyraz tak, aby vracel hodnotu v registru target, a vrati -- prislusny kod compileExpression::Expression->Int->TMonad [Instruction] compileExpression expression target = case expression of Let locals expr -> compileLet locals expr target Apply fn param -> compileApply fn param target Number val -> return [ILoad val target] Variable var -> compileVar expression target Plus e1 e2 -> compileArith e1 e2 IPlus target Mul e1 e2 -> compileArith e1 e2 IMul target Minus e1 e2 -> compileArith e1 e2 IMinus target Div e1 e2 -> compileArith e1 e2 IDiv target Case expr cases dflt -> compileCase expr cases dflt target -- kompiluje let. Vytvorime thunky pro definovane lokalni promenne -- a zkompilujeme expr s moznosti pristupu k temto lokalnim promennym -- drobny trik -- musime zajistit, aby fungovala rekurzivni volani compileLet::[Equation]->Expression->Int->TMonad [Instruction] compileLet locals expr target = do bind defs claimRegs <- mapM claimReg defs mkThunkCodes <- mapM makeLocalThunk locals eval <- compileExpression expr target unbind defs return (concat claimRegs ++ concat mkThunkCodes ++ eval) where defs = map eqName locals claimReg def = do Just reg <- findLocal def return [ILoad 0 reg] makeLocalThunk (Equation fn [] expr) = case expr of Number _ -> prepareScalar fn expr Variable x -> do loc <- findLocal x case loc of Just _ -> makeApplyThunk fn $ Apply (Variable "id") expr Nothing -> prepareScalar fn expr _ -> makeApplyThunk fn expr prepareScalar fn expr = do Just reg <- findLocal fn code <- loadScalar expr 0 return $ code ++ [IRewrite reg 0] makeApplyThunk fn expr = do let (Variable f, args) = splitApply expr Just reg <- findLocal fn Just lthunk <- findGlobal f addArgs <- mapM (addArg 0) args return $ ICall lthunk 0 : concat addArgs ++ [IRewrite reg 0] addArg f arg = do reg <- allocateReg code <- loadScalar arg reg return $ code ++ [IApply f reg f] splitApply app = splitApply' app [] splitApply' (Apply x arg) rest = splitApply' x (arg:rest) splitApply' f rest = (f, rest) -- kompiluje aplikaci funkce. compileApply::Expression->Expression->Int->TMonad [Instruction] compileApply fn x target = do temp <- allocateReg getFnCode <- compileExpression fn temp arg <- allocateReg pCode <- loadScalar x arg rthunk <- allocateReg return $ getFnCode ++ pCode ++ [IApply temp arg rthunk, IExecute rthunk, IMove 0 target] -- kompiluje vyhodnoceni promenne compileVar::Expression->Int->TMonad [Instruction] compileVar var target = do reg <- allocateReg load <- loadScalar var reg return $ load ++ [IExecute reg, IRewrite reg 0, IMove 0 target] -- kompiluje aritmeticky vyraz compileArith::Expression->Expression->(Int->Int->Int->Instruction)->Int->TMonad [Instruction] compileArith a b op target = do fname <- curFN ra <- allocateReg codeA <- compileExpression a ra rb <- allocateReg codeB <- compileExpression b rb return $ codeA ++ codeB ++ [op ra rb target] -- zkompiluje case compileCase::Expression->[(Int, Expression)]->Expression->Int->TMonad [Instruction] compileCase expr cases dflt target = do reg <- allocateReg code <- compileExpression expr reg branchCodes <- mapM (compileBranch reg) cases dfltLoad <- loadScalar dflt 0 return $ code ++ dfltLoad ++ concat branchCodes ++ [IExecute 0, IMove 0 target] where compileBranch reg (val, e) = do tmp <- allocateReg rslt <- allocateReg code <- loadScalar e rslt return $ code ++ [ILoad val tmp, ICExecute tmp reg rslt] -- nahraje Number nebo Variable do registru loadScalar::Expression->Int->TMonad [Instruction] loadScalar (Number n) target = return [ILoad n target] loadScalar (Variable x) target = do l <- findLocal x case l of Just reg -> return [IMove reg target] Nothing -> do Just fn <- findGlobal x return [ICall fn target] isScalar::Expression->Bool isScalar (Number _) = True isScalar (Variable _) = True isScalar _ = False -- najde registr, v nemz je lokalni definice promenne var findLocal::String->TMonad (Maybe Int) findLocal var = do regs <- getState >>= return . ecLocal return $ lookup var regs -- najde misto v pameti pro kod, kde je ulozena definice funkce fn findGlobal::String->TMonad (Maybe Int) findGlobal fn = do functions <- getState >>= return . ecFunctions return $ lookup fn functions -- naalokuje novy registr allocateReg::TMonad Int allocateReg = do state <- getState let reg = ecFreeReg state setState state{ecFreeReg = reg + 1} return reg -- odstrani lokalni promenne l unbind::[String]->TMonad () unbind l = do state <- getState let regs = ecLocal state l' = map (\x->(x,undefined)) l newRegs = deleteFirstsBy (\(n1,_) (n2,_) -> n1 == n2) regs l' setState state{ecLocal = newRegs} -- naalokuje lokalni promenne l bind::[String]->TMonad () bind l = do regs <- getState >>= return . ecLocal newRegs <- foldM bindVar regs l state <- getState setState state{ecLocal = newRegs} return () where bindVar regs var = do fn <- curFN reg <- allocateReg return ((var,reg) : regs) -- prevede program do kanonickeho tvaru (vsechny argumenty funkci jsou bud -- konstanty nebo promenne, stejne tak vysledky vetvi case, let definice -- jsou tvaru var = f arguments, kde pokud argumenty nejsou prazdne, je -- f globalni funkce) simplify::Equation->[Equation] simplify equation = snd $ simplify' (genFreeNames "free", []) equation type SState = (FreeNames, [Equation]) type SEState = (FreeNames, Expression, [Equation]) type FreeNames = [String] -- vygeneruje nekonecny seznam nepouzitych jmen, koncicich zadanym suffixem genFreeNames::String->[String] genFreeNames suffix = map (\n->show n ++ suffix) [1..] simplify'::SState->Equation->SState simplify' (fNames, eqs) (Equation f params expr) = foldl simplify' (newFNames, Equation f params newExpr : eqs) newEquations where (newFNames, newExpr, newEquations) = simplifyExpr (fNames, expr, []) simplifyExpr::SEState->SEState simplifyExpr (freeNames, Let eqs expr, rest) = (free2, Let eqs' expr', r2) where (free1, expr', r1) = simplifyExpr (freeNames, expr, rest) (free2, eqs', r2) = foldl simplifyLetEq (free1, [], r1) eqs simplifyLetEq (fr, es, rst) (Equation x param exp) = let ((fr', var, rst'), letEq) = simplifyToVar (fr, exp, rst) param in (fr', maybeToList letEq ++ Equation x [] var : es, rst') simplifyExpr (freeNames, Apply f arg, rest) = (free2, cLet (maybeToList letEq) (Apply f' var), r2) where ((free1, var, r1), letEq) = simplifyToVar (freeNames, arg, rest) [] (free2, f', r2) = simplifyExpr (free1, f, r1) simplifyExpr (freeNames, Case expr alts dflt, rest) = (free3, cLet letEqs (Case expr' alts' dflt'), r3) where letEqs = catMaybes (dLetEq:aLetEqs) (free1, expr', r1) = simplifyExpr (freeNames, expr, rest) ((free2, dflt', r2), dLetEq) = simplifyToVar (free1, dflt, r1) [] (free3, alts', aLetEqs, r3) = foldl simplifyAlt (free2, [], [], r2) alts simplifyAlt (fr, as, les, rst) (val, exp) = let ((nFr, var, nRst), letEq) = simplifyToVar (fr, exp, rst) [] in (nFr, (val, var):as, letEq:les, nRst) simplifyExpr x@(_, Plus a b, _) = simplifyArith x Plus a b simplifyExpr x@(_, Mul a b, _) = simplifyArith x Mul a b simplifyExpr x@(_, Minus a b, _) = simplifyArith x Minus a b simplifyExpr x@(_, Div a b, _) = simplifyArith x Div a b simplifyExpr x = x simplifyArith::SEState->(Expression->Expression->Expression)->Expression->Expression->SEState simplifyArith (freeNames, _, rest) op a b = (f2, op a' b', r2) where (f1, a', r1) = simplifyExpr (freeNames, a, rest) (f2, b', r2) = simplifyExpr (f1, b, r1) -- vytvori novou funkci pocitajici vyraz, vytvori promennou a vrati rovnici, -- kterou se do teto promenne priradi funkce s parametry odpovidajicimi -- volnym promennym vyrazu simplifyToVar::SEState->[String]->(SEState, Maybe Equation) simplifyToVar (freeNames, Variable var, rest) params = ((freeNames, Variable var, rest), Nothing) simplifyToVar (freeNames, Number n, rest) params = ((freeNames, Number n, rest), Nothing) simplifyToVar (freeNames, expr, rest) params = ((f1, Variable varName, Equation fName allPars expr : rest), Just $ Equation varName [] fCall) where (fName:varName:f1) = freeNames pars = freeVars expr \\ params allPars = pars ++ params fCall = foldl Apply (Variable fName) $ map Variable pars -- nalezne volne promenne vyrazu freeVars::Expression->[String] freeVars expr = nub $ freeVars' expr where freeVars' (Let eqs expr) = nub (fE ++ fEq) \\ map eqName eqs where fE = freeVars' expr fEq = concatMap eqFVars eqs eqFVars (Equation _ param expr) = freeVars expr \\ param freeVars' (Apply e1 e2) = freeVars' e1 ++ freeVars' e2 freeVars' (Number _) = [] freeVars' (Variable x) = [x] freeVars' (Plus e1 e2) = freeVars' e1 ++ freeVars' e2 freeVars' (Minus e1 e2) = freeVars' e1 ++ freeVars' e2 freeVars' (Mul e1 e2) = freeVars' e1 ++ freeVars' e2 freeVars' (Div e1 e2) = freeVars' e1 ++ freeVars' e2 freeVars' (Case e alts d) = freeVars' e ++ freeVars' d ++ concatMap (freeVars' . snd) alts main::IO () main = do print test print $ interpret test