diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 0.99999 +version: 1.0 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -9,7 +9,7 @@ import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.Serialize as Ser -import Elf (writeElf) +import Elf (writeElf,entryAddress) import Foreign hiding (void) import My.Control.Monad import My.Control.Monad.State hiding ((<.>)) @@ -36,26 +36,27 @@ PrintVersion -> printVersion Compile -> doCompile s -version = "0.99999" +formatEntry Elf64 = entryAddress +formatEntry (Raw n) = n + +version = "1.0" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version newtype Str = Str String instance Show Str where show (Str s) = s -doTestOlder = return True -- for testing purposes, turn makefile-style file dependencies checks on or off - doCompile opts = case programs opts of [] -> interactive progs -> mapM_ compileProgram progs where + entry = formatEntry $ outputFmt opts languageFile language = languageDir optslanguage<.>"l" findSource language = findM doesFileExist (concat [[base<.>"a",base] | dir <- sourceDirs opts , let base = dirlanguage]) - readProg s = let (a,':':b) = break (==':') s in (a,b) interactive = void $ compileFile "/dev/stdin" - compileProgram (readProg -> (language,root)) = withDefaultContext $ do + compileProgram (language,root) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language l <- doF languageF get rootSym <- stateF languageF $ internSym root @@ -64,12 +65,13 @@ top <- gets compTop contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] - writeElf root contents + case outputFmt opts of + Elf64 -> writeElf root contents + Raw _ -> B.writeFile root contents compileLanguage force name = do let langFile = languageFile name source <- findSource name - skip <- return (not force) <&&> fileExist langFile - <&&> maybe (return True) (\s -> langFile `newerThan` s) source + skip <- return (not force) <&&> fileExist langFile <&&> maybe (return True) (langFile `newerThan`) source l <- if skip then either (\e -> error $ "Error reading language file "++langFile++": "++e) id $< Ser.decode $< B.readFile langFile else do putStrLn $ "Compiling language "++name++"..." @@ -79,13 +81,12 @@ return lang return (not skip,l) - compileFile src = withDefaultContext $ (>> gets language) $ do + compileFile src = withDefaultContext entry $ (>> gets language) $ do str <- readFile src let sTree = concat $ parseAlpha src str init <- mapM compileExpr sTree languageState $ modify $ \e -> exportLanguage $ e { initializeL = init } where compileExpr expr = do - debug expr `seq` return () symExpr <- languageState $ envCast expr trExpr <- doTransform symExpr (code,imports) <- languageState $ compile [] Nothing trExpr diff --git a/src/Compile.hs b/src/Compile.hs --- a/src/Compile.hs +++ b/src/Compile.hs @@ -46,7 +46,7 @@ sequence_ [createEdge TimeDep n' n | (_,l) <- code, n' <- l] return (SymVal Value dest,(n:concatMap fst code,[n])) -compileBuiltin _ _ [] = nullCodeVal (IntVal 0) +compileBuiltin _ dest [] = compileValue dest (IntVal 0) compileBuiltin b dest args = compileBy (Op b) dest args compileCall = compileBuiltin BCall @@ -94,7 +94,11 @@ compile' Nothing arg *>>= \v -> makeBackBranch v alts compileAxiom XVerb dest [Group (name:args),expr] = do - (sym,code) <- compileBody args name expr + bv@BindVar { bindSym = sym } <- bindFromSyntax name + ret <- case bindSubs bv of + [] -> newVar >>= \ret -> return bv { bindSym = ret } + (h,_):_ -> return h + code <- compileExpr args (Just ret) expr lift $ modify $ exportSymVal sym (Verb code) compile' dest (Symbol sym) compileAxiom XVerb dest [Symbol s,Symbol a] = do @@ -122,11 +126,6 @@ (code,imps) <- lift $ compile args ret expr modifyF importsF (imps++) return code -compileBody args retBind body = do - bv <- bindFromSyntax retBind - ret <- newVar - code <- compileExpr args (Just bv { bindSym = ret }) body - return (bindSym bv,code) compileValue dest val = do c <- singleCode $< case dest of Just v -> createNode (Instr $ set v val) diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs --- a/src/Compile/Utils.hs +++ b/src/Compile/Utils.hs @@ -2,28 +2,34 @@ module Compile.Utils where import Compile.State as CS -import qualified My.Data.Graph as G -import My.Prelude +import Data.Array +import Data.Function +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Set as S import My.Control.Monad import My.Control.Monad.State +import qualified My.Data.Graph as G import My.Data.List import My.Data.Tree - -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Function -import Data.Maybe +import My.Prelude import PCode import Syntax - import Translate -import Debug.Trace +flattenable code = map (f . instr) code' + where f (Branch v alts) = Branch v (map (a!) alts) + f i = i + (bounds,instr,nexts,_) = navigate code + t = spanningTree 0 nexts ; code' = flatten t + a = array bounds (zip code' [0..]) uniquify a r [] = uniquify a r [ret] -uniquify args ret code = flatten $< descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts +uniquify args ret code = do + ret <- descendM uniq (M.fromList $ zip syms syms) $ spanningTree 0 nexts + return (flatten ret) where syms = concatMap bindSyms $ maybe id (:) ret args - (_,instr,nexts,_) = navigate code + (_,instr,nexts,_) = navigate $ flattenable code uniq (instr -> Bind bv v) m = do news <- mapM (const $ state createSym) (bindSyms bv) let m' = foldr (uncurry M.insert) m (zip (bindSyms bv) news) @@ -32,7 +38,7 @@ localVal m (SymVal t s) | (t==Value || t==Address) && not (M.member s m) = SymVal GValue s localVal m v = v translateBy m s = fromMaybe s $ M.lookup s m - withLocals m (Op b v vs) = (Op b v (map (localVal m) vs),M.insert v v m) + withLocals m (Op b v vs) = (Op b v (map (localVal m) vs),M.insertWith (flip const) v v m) withLocals m (Branch v a) = (Branch (localVal m v) a,m) withLocals m i = (i,m) diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -76,6 +76,9 @@ foreign export ccall "createSym_" createSym_ :: IO ID foreign import ccall "&createSym_" createSym_ptr :: FunPtr (IO ID) createSym_ = stateF languageF createSym +foreign export ccall "numSym_" numSym_ :: Int -> IO ID +foreign import ccall "&numSym_" numSym_ptr :: FunPtr (Int -> IO ID) +numSym_ = stateF languageF . internSym . show foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ()) foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ())) @@ -110,6 +113,7 @@ ("alpha/c@" , Right $ exportAlpha callStub1 compAddr_ptr), ("alpha/create-symbol" , Right $ exportAlpha callStub0 createSym_ptr), + ("alpha/number-symbol" , Right $ exportAlpha callStub1 numSym_ptr), ("alpha/symbol-name" , Right $ exportAlpha callStub1 symName_ptr), ("alpha/name-symbol" , Right $ exportAlpha callStub1 nameSym_ptr), @@ -120,7 +124,6 @@ ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) - ] doTransform syn = gets transform >>= ($syn) . maybe return tr @@ -152,7 +155,7 @@ 1 -> do liftM (Symbol . ID) $ peek p' -initialContext = C lang jitA M.empty (fromIntegral entryAddress) Nothing +initialContext entry = C lang jitA M.empty (fromIntegral entry) Nothing where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty) where st (s,v) = do i <- stateF fstF (internSym s) @@ -160,7 +163,7 @@ Left v -> modifyF fstF (setSymVal i v) Right p -> modifyF sndF (M.insert i p) -withDefaultContext = withState initialContext +withDefaultContext = withState . initialContext contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a languageState = contextState . doF languageF diff --git a/src/My/Control/Monad/RWTL.hs b/src/My/Control/Monad/RWTL.hs --- a/src/My/Control/Monad/RWTL.hs +++ b/src/My/Control/Monad/RWTL.hs @@ -24,6 +24,7 @@ where (p',f'',a,w) = runRWTL tl r p f' (p'',f',b,w') = runRWTL (cc a) r p' f return a = RWTL (\r p f -> (p,f,a,mempty)) + -- the Monoid constraint is not necesary if you want to be precise, -- but the alternative to liftM would be extremely ugly instance Monoid w => Functor (RWTL r w p f) where diff --git a/src/My/Data/SetBy.hs b/src/My/Data/SetBy.hs --- a/src/My/Data/SetBy.hs +++ b/src/My/Data/SetBy.hs @@ -2,7 +2,7 @@ ,empty,fromList,fromAscList ,null ,toList,toAscList - ,insert,delete,member + ,insert,delete,deleteMany,member ,findMin ,partition ,union) where @@ -35,6 +35,7 @@ insert e (SetBy cmp t) = SetBy cmp (AVL.push (cmp e) e t) delete e (SetBy cmp t) = SetBy cmp (fromMaybe t $ fmap snd $ AVL.tryPop (cmp e) t) +deleteMany l s = foldr delete s l member e (SetBy cmp t) = isJust $ AVL.tryRead t (cmp e) findMin (SetBy _ t) = AVL.assertReadL t diff --git a/src/My/Data/Tree.hs b/src/My/Data/Tree.hs --- a/src/My/Data/Tree.hs +++ b/src/My/Data/Tree.hs @@ -8,10 +8,11 @@ import qualified Data.Set as S import Control.Monad.State -nubT t = evalState (unfoldTreeM unfold t) S.empty - where unfold (Node a subs) = do - modify (S.insert a) ; s <- get - return (a,[sub | sub <- subs, not (S.member (rootLabel sub) s)]) +nubT t = head $ evalState (nubNode t) S.empty + where nubNode (Node a subs) = gets (S.member a) >>= \b -> if b then return [] else do + modify (S.insert a) + subs <- mapM nubNode subs + return [Node a (concat subs)] iterateT seed f = unfoldTree (\a -> (a,f a)) seed branches (Node a []) = [[a]] diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -1,4 +1,4 @@ -module Options (Architecture(..),Action(..),Settings(..),helpMsg,getSettings) where +module Options (Architecture(..),Action(..),Settings(..),Format(..),helpMsg,getSettings) where import Specialize.Architecture import System.Console.GetOpt @@ -9,50 +9,69 @@ | SourceDir FilePath | Program FilePath | LanguageDir FilePath - | Architecture Architecture + | Architecture Architecture + | Format Format deriving Show data Action = PrintHelp | PrintVersion | Compile deriving Show - +data Format = Elf64 | Raw Int + deriving Show data Settings = Settings { action :: Action, sourceDirs :: [FilePath], languageDir :: FilePath, - programs :: [FilePath], - outputArch :: Architecture + programs :: [(String,String)], + outputArch :: Architecture, + outputFmt :: Format } deriving Show +splitArg s = case break (==':') s of + (a,':':b) -> a:splitArg b + ("","") -> [] + (a,"") -> [a] + options = - [Option ['h'] ["help"] (NoArg Help) + [Option ['h','?'] ["help"] (NoArg Help) "prints usage information" ,Option ['v'] ["version"] (NoArg Version) "prints Alpha's version information" ,sep - ,Option ['S'] ["source-dir"] (ReqArg SourceDir "DIR") - "adds DIR to the list of directories searched for sources" - ,Option ['L'] ["language-dir"] (ReqArg LanguageDir "DIR") - "casts all languages in DIR (default '.')" + ,Option ['S'] ["source-dir"] (ReqArg SourceDir "") + "adds to the list of directories searched for source files" + ,Option ['L'] ["language-dir"] (ReqArg LanguageDir "") + "writes and seeks all language files in (defaults to the current directory)" ,sep - ,Option ['a'] ["architecture"] (ReqArg (Architecture . str2arch) "ARCH") - $ "specializes for ARCH instead of the local architecture (ARCH is one of "++foldr glue "" (tails archNames)++")" + ,Option ['a'] ["architecture"] (ReqArg (Architecture . str2arch) "") + $ "specializes for instead of the host architecture ( can be one of "++foldr glue "" (tails archNames)++")" + ,Option ['f'] ["format"] (ReqArg (Format . str2fmt) "") + $ "writes the output programs in the specified format ( can be one of elf64 or \n" + ++"raw: where is the start address)" ] where str2arch s = fromMaybe (error $ "Invalid architecture name "++s) $ lookup s $ zip archNames architectures + str2fmt s = case splitArg s of + ["elf64"] -> Elf64 + ["raw",n] -> Raw (read n) + _ -> error ("Invalid format argument "++show s) archNames = map archName architectures glue [a] _ = a glue [a,_] t = a++" or "++t glue (a:_) t = a++", "++t sep = Option [] [] undefined "-----------------" -helpMsg = usageInfo "Usage: Alpha " options +helpMsg = usageInfo "Usage: alpha (