packages feed

alpha 0.99999 → 1.0

raw patch · 12 files changed

+108/−76 lines, 12 files

Files

alpha.cabal view
@@ -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
src/Alpha.hs view
@@ -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 opts</>language<.>"l"     findSource language = findM doesFileExist (concat [[base<.>"a",base] | dir <- sourceDirs opts                                                                          , let base = dir</>language])-    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
src/Compile.hs view
@@ -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)
src/Compile/Utils.hs view
@@ -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)
src/Context.hs view
@@ -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
src/My/Control/Monad/RWTL.hs view
@@ -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
src/My/Data/SetBy.hs view
@@ -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
src/My/Data/Tree.hs view
@@ -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]]
src/Options.hs view
@@ -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 "<dir>") +   "adds <dir> to the list of directories searched for source files"+  ,Option ['L'] ["language-dir"] (ReqArg LanguageDir "<dir>") +   "writes and seeks all language files in <dir> (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) "<arch>") +   $ "specializes for <arch> instead of the host architecture (<arch> can be one of "++foldr glue "" (tails archNames)++")"+  ,Option ['f'] ["format"] (ReqArg (Format . str2fmt) "<fmt>")+   $ "writes the output programs in the specified format (<fmt> can be one of elf64 or \n"+   ++"raw:<n> where <n> 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> <files>" options+helpMsg = usageInfo "Usage: alpha (<option>|<language>:<symbol>)..." options -defaultSettings progs = Settings Compile ["."] "." progs hostArch+defaultSettings progs = Settings Compile ["."] "." (map readProg progs) hostArch Elf64+  where readProg p = case splitArg p of+          [l,s] -> (l,s)+          _ -> error $ "Ill-formed argument '"++p++"'. Should be of the form <language>:<symbol>" getSettings [] = Right $ defaultSettings [] getSettings args = case getOpt Permute options args of-  (opts,mods,[]) -> Right $ foldl handleOpt (defaultSettings mods) opts+  (opts,progs,[]) -> Right $ foldl handleOpt (defaultSettings progs) opts   (_,_,err) -> Left $ helpMsg ++ concatMap ("\n"++) err   where handleOpt s Help             = s { action = PrintHelp }         handleOpt s Version          = s { action = PrintVersion }         handleOpt s (SourceDir d)    = s { sourceDirs = d : sourceDirs s }         handleOpt s (LanguageDir d)  = s { languageDir = d }         handleOpt s (Architecture a) = s { outputArch = a }+        handleOpt s (Format f)       = s { outputFmt = f }
src/PCode/Builtin.hs view
@@ -8,7 +8,7 @@              | BSet | BSetSX              deriving (Show,Eq) -isBinOp b = b/=BCall && b/=BSet && b/=BNot+isBinOp b = b`elem`[BCall,BSet,BSetSX,BNot]  bNames = [(BAdd,"+"),(BMul,"*"),(BSub,"-"),(BDiv,"/"),(BMod,"%"),           (BLowerThan,"<"),(BGreaterThan,">"),(BLowerEq,"<="),(BGreaterEq,">="),
src/Specialize.hs view
@@ -55,11 +55,11 @@         nextFuture i f = snd4 $ runInstr i undefined f (const Nothing)         gens = array bounds $ zip (flatten codeTree) [0..]         gens' = array bounds $ zip [0..] (flatten codeTree)-        getPast g i | g >= gens!i = Just $ fst $ instrs!#i-                    | otherwise = Nothing+        getPast g i | g == maximum (filter (<=(gens!i)) $ map (gens!) $ prevs i) = Nothing+                    | otherwise = Just $ fst $ instrs!i         instrs = array bounds $ flatten $ descend desc past codeTree           where desc i p = ((i,(p,c)),p')-                  where ~(p',_,_,c) = runInstr i p (snd $ futures!g!#i) (getPast g)+                  where ~(p',_,_,c) = runInstr i p (snd $ futures!g!i) (getPast g)                         g = gens!i         futures = fmap snd $ listArray bounds $ iterate nextFut (1,initial)           where initial = execState (sequence_ [changeFuture i 0 (futureOf i) | i <- map last (branches codeTree)])@@ -68,7 +68,7 @@                                    | otherwise = emptyFuture                 nextFut (g,fa) = (g+1,fa')                   where fa' = execState (sequence_ [changeFuture i g newFut | i <- prevs instr, head (nexts i)==instr]) fa-                        instr = gens'!g ; newFut = Future $ registers $ fst (instrs!#instr)+                        instr = gens'!g ; newFut = Future $ registers $ fst (instrs!instr)                 changeFuture i g f = puti i (g,f) >> mapM_ propagate (prevs i)                 propagate i = do                    let j = head (nexts i)
src/Specialize/X86_64.hs view
@@ -210,7 +210,7 @@   (Left r,Left r') -> rr dest r r'   (Left r,Right v) ->  ri dest r v   (Right v,Left r) -> ir dest v r-  (Right (s,n),Right (s',n')) -> movi dest (max s s',liftM2 ii n n')+  (Right (s,n),Right (s',n')) -> movi dest (min s s',liftM2 ii n n')  argVal (IntVal n) = Right $ withSize n argVal (SymVal Size s) = Right $ withSize $ fromMaybe defSize $ M.lookup s (sizes ?info)@@ -315,31 +315,30 @@                                       $ mfilter (`SB.member` free) (BM.lookup s regs)         argAlloc (_,Just r) = return (Left $ Right r)         argNew = leftK (allocReg <|||> return)-    modify $ \s -> foldr SB.delete s fixed+    modify $ SB.deleteMany fixed     alls <- mapM argAlloc args-    modify $ \s -> foldr SB.delete s [r | Left (Right r) <- alls]+    modify $ SB.deleteMany [r | Left (Right r) <- alls]     allocs <- mapM argNew alls     let assocs = filter (\(r,arg,_) -> not $ (myWorkIsDone r ||| const False) (argVal arg))                  $ lefts [left (,arg,bind arg) all | all <- allocs | (arg,_) <- args]-        bind arg = argValSym arg >>= binding+          where bind (SymVal t s) | t`elem`[Value,Address] = binding s+                bind _ = Nothing         groups = classesBy ((==)`on`parent) assocs         parent (_,_,b) = fmap fst b         myWorkIsDone r s = BM.pairMember (s,r) regs         loadGroup g = do           base <- loadRoot (parent $ head g)           mapM_ (load base) g-          where load base (r,arg,b) = lift regInfo >>= \(regs,_) -> do-                  when (BM.memberR r regs) (storeRegs [r])-                  lift $ case argVal arg of-                    Right v -> movi r v-                    Left s -> case lookupRegIn regs s of-                      Just r' -> mov r r'-                      Nothing -> do-                        n <- maybe (stackAddr (varSize s) s) return $ fmap snd b-                        if symValType arg == Value-                          then ld r (base,fi n,fi (varSize s))-                          else lea r base (fi n)-                  lift $ associate r ((Just ||| const Nothing) $ argVal arg)  +          where load base (r,arg,b) = do+                  storeRegs [r] ; lift $ do+                    case argVal arg of+                      Right v -> movi r v+                      Left s -> regInfo >>= \(regs,_) -> case (lookupRegIn regs s,symValType arg) of+                        (Just r',Value) -> mov r r'+                        (_,t) -> maybe (stackAddr (varSize s) s) return (fmap snd b) >>= \n -> case t of+                          Value -> ld r (base,fi n,fi (varSize s))+                          Address -> lea r base (fi n)+                    associate r $ (Just ||| const Nothing) (argVal arg)        mapM_ loadGroup groups     return allocs@@ -389,7 +388,9 @@     storeRegs [r | (s,r) <- BM.toList regs, not (isActive s), isJust (binding s)]     lift $ modifyF registersF (BM.filter (const . isActive)) compile' (Branch v alts) = withFreeSet $ do-  let alignPast i = listening $ maybe doNothing (preserve . alignWith . registers) (instrPast i)+  let alignPast i = listening $ maybe doNothing (\p -> preserve $ do+                                                    lift $ putF frameF (frame p)+                                                    alignWith $ registers p) (instrPast i)       jmpc short long (BC ~(e,s,_)) (BC ~(e',s',_)) = BC (length long+4,length code,return $ B.pack code)         where de = e'-e ; ds = s'-s               code | de==0 = []