From 650405c2fe3a31bbb816c15971e1cd646d0f858b Mon Sep 17 00:00:00 2001 From: Cat's Eye Technologies Date: Mon, 31 Mar 2014 23:14:07 +0100 Subject: [PATCH] Initial import. --- .hgignore | 5 + build.sh | 4 + eg/compare.60pical | 14 +++ eg/simple.60pical | 19 ++++ src/Main.hs | 260 +++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 302 insertions(+) create mode 100644 .hgignore create mode 100755 build.sh create mode 100644 eg/compare.60pical create mode 100644 eg/simple.60pical create mode 100644 src/Main.hs diff --git a/.hgignore b/.hgignore new file mode 100644 index 0000000..7442683 --- /dev/null +++ b/.hgignore @@ -0,0 +1,5 @@ +syntax: glob + +*.o +*.hi +bin/* diff --git a/build.sh b/build.sh new file mode 100755 index 0000000..b29b884 --- /dev/null +++ b/build.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +mkdir -p bin +ghc src/Main.hs -o bin/sixtypical diff --git a/eg/compare.60pical b/eg/compare.60pical new file mode 100644 index 0000000..405613f --- /dev/null +++ b/eg/compare.60pical @@ -0,0 +1,14 @@ +reserve byte m_high +reserve byte m_low +reserve byte n_high +reserve byte n_low + +routine compare_16_bit { + lda m_high + cmp n_high + beq { + lda m_low + cmp n_low + } else { + } +} diff --git a/eg/simple.60pical b/eg/simple.60pical new file mode 100644 index 0000000..6b9eebf --- /dev/null +++ b/eg/simple.60pical @@ -0,0 +1,19 @@ +assign word fnord 4000 +assign byte blerf 4002 + +reserve byte foo +reserve word bar + +routine hello { + lda fnord + cmp blerf + lda foo +} + +routine bye { + lda fnord + cmp bar +} + +routine byee { +} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..ca2de34 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,260 @@ +-- encoding: UTF-8 + +module Main where +--module Sixtype where + +import qualified Data.Map as Map + +import System.IO +import System.Environment +import System.Exit + +import Text.ParserCombinators.Parsec + +-- -- -- -- machine model -- -- -- -- + +type Address = Int -- LET'S ASSUME THIS IS AT LEAST 16 BITS + +type LocationName = String + +data Register = A | X | Y -- | MemLoc LocationName + deriving (Show, Ord, Eq) + +allRegisters = [A, X, Y] + +-- -- -- -- program model -- -- -- -- + +data Size = Byte + | Word + deriving (Show, Ord, Eq) + +data Decl = Assign LocationName Size Address -- .alias + | Reserve LocationName Size -- .word, .byte + deriving (Show, Ord, Eq) + +type RoutineName = String + +data Instruction = LOAD Register LocationName + | COPY Register Register + | CMP Register LocationName + | JSR RoutineName + | IFEQ [Instruction] [Instruction] + | NOP + deriving (Show, Ord, Eq) + +data Routine = Routine RoutineName [Instruction] + deriving (Show, Ord, Eq) + +data Program = Program [Decl] [Routine] + deriving (Show, Ord, Eq) + +-- -- -- -- data-flow-analysis context -- -- -- -- + +data Usage = Unknown + | Value LocationName -- obviously a bit daft for now + | Retained Register + deriving (Show, Ord, Eq) + +type RoutineContext = Map.Map Register Usage + +type ProgramContext = Map.Map RoutineName RoutineContext + +-- +-- Utility function: +-- Take 2 routine contexts -- the current routine and a routine that was just +-- JSR'ed to (immediately previously) -- and merge them to create a new +-- context for the current routine. +-- +mergeRoutCtxs routCtx calledRoutCtx = + let + -- insert the values into routCtx + -- TODO, first compare them + -- TODO, if not equal, 'poison' them + -- TODO, other special cases (eg Unknown) + poison key value routCtxAccum = + case value of + -- if the called routine retains it, + -- we keep our idea of it -- but TODO + -- should we mark it "was retained"? + Retained reg -> + routCtxAccum + _ -> + Map.insert key value routCtxAccum + in + Map.foldrWithKey (poison) routCtx calledRoutCtx + +-- -- -- -- static analyzer -- -- -- -- + +checkProgram (Program decls routines) = + checkRoutines routines Map.empty + +checkRoutines [] progCtx = progCtx +checkRoutines (rout@(Routine name _) : routs) progCtx = + let + routCtx = Map.fromList $ map (\reg -> (reg, Retained reg)) allRegisters + routAnalysis = checkRoutine rout progCtx routCtx + progCtx' = Map.insert name routAnalysis progCtx + in + checkRoutines routs progCtx' + +checkRoutine (Routine _ []) progCtx routCtx = routCtx +checkRoutine (Routine name (instr : instrs)) progCtx routCtx = + let + routCtx' = checkInstr instr progCtx routCtx + in + checkRoutine (Routine name instrs) progCtx routCtx' + +checkInstr (LOAD reg addr) progCtx routCtx = + Map.insert reg (Value addr) routCtx +checkInstr (COPY src dst) progCtx routCtx = + Map.insert dst (Map.findWithDefault Unknown src routCtx) routCtx +checkInstr (JSR name) progCtx routCtx = + case Map.lookup name progCtx of + Just calledRoutCtx -> + mergeRoutCtxs routCtx calledRoutCtx + Nothing -> + error ("can't call routine '" ++ name ++ "' before it is defined") +checkInstr (CMP reg addr) progCtx routCtx = + -- TODO: mark Carry bit as "touched" here + routCtx +checkInstr (IFEQ b1 b2) progCtx routCtx = + -- TODO: oooh, this one's gonna be fun + routCtx +checkInstr NOP progCtx routCtx = + routCtx + +-- -- -- -- parser -- -- -- -- +{- + +Toplevel := {Decl} {Routine}. +Decl := "reserve" Size LocationName + | "assign" Size LocationName Address. +Size := "byte" | "word". +Routine := "routine" RoutineName Block. +Block := "{" {Command} "}". +Command := "beq" Block "else" Block + | "lda" (LocationName | Immediate) + | "txa" | "tax" | "tya" | "tay" + | "cmp" (LocationName | Immediate) + +-} + +toplevel :: Parser Program +toplevel = do + decls <- many (assign <|> try reserve) + routines <- many routine + return $ Program decls routines + +reserve :: Parser Decl +reserve = do + string "reserve" + spaces + sz <- size + spaces -- size does not do its own spacesising + name <- locationName + return $ Reserve name sz + +assign :: Parser Decl +assign = do + string "assign" + spaces + sz <- size + spaces -- size does not do its own spacesising + name <- locationName + addr <- address + return $ Assign name sz addr + +size :: Parser Size +size = do + s <- (string "byte") <|> (string "word") + return $ case s of + "byte" -> Byte + "word" -> Word + +routine :: Parser Routine +routine = do + string "routine" + spaces + name <- routineName + instrs <- block + return (Routine name instrs) + +block :: Parser [Instruction] +block = do + string "{" + spaces + cs <- many command + string "}" + spaces + return cs + +command :: Parser Instruction +command = cmp <|> lda <|> beq + +cmp :: Parser Instruction +cmp = do + string "cmp" + spaces + l <- locationName + return (CMP A l) + +lda :: Parser Instruction +lda = do + string "lda" + spaces + l <- locationName + return (LOAD A l) + +beq :: Parser Instruction +beq = do + string "beq" + spaces + b1 <- block + string "else" + spaces + b2 <- block + return (IFEQ b1 b2) + +routineName :: Parser String +routineName = do + c <- letter + cs <- many (alphaNum <|> char '_') + spaces + return (c:cs) + +locationName :: Parser String +locationName = do + c <- letter + cs <- many (alphaNum <|> char '_') + spaces + return (c:cs) + +address :: Parser Address +address = do + digits <- many digit + spaces + return (read digits :: Address) + +-- -- -- -- driver -- -- -- -- + +main = do + args <- getArgs + case args of + [filename] -> do + programText <- readFile filename + case parse toplevel "" programText of + Right program -> do + putStrLn $ show $ program + putStrLn $ show $ checkProgram program + Left problem -> do + hPutStrLn stderr (show problem) + exitWith $ ExitFailure 1 + _ -> do + putStrLn "Usage: sixtypical filename.60pical" + exitWith $ ExitFailure 1 + +{- +test = checkProgram [(Routine "wait" [LOAD Y "score", COPY Y A]), + (Routine "main" [LOAD X "score", JSR "wait"])] + Map.empty +-}