packages feed

alpha 0.9.5 → 0.9.6

raw patch · 16 files changed

+136/−111 lines, 16 files

Files

alpha.cabal view
@@ -1,5 +1,5 @@ name:           alpha-version:        0.9.5+version:        0.9.6 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@@ -22,6 +22,6 @@ executable alpha   build-depends:  base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix   main-is:        Alpha.hs-  other-modules:  Alpha, Compile, Compile.State, Compile.Utils, Context, Context.Language, Context.Types, Elf, ID, My.Control.Monad, My.Control.Monad.State, My.Control.Monad.TimeLine, My.Data.Graph, My.Data.List, My.Prelude, Options, PCode, PCode.Builtin, PCode.Instruction, PCode.Value, Serialize, Specialize, Specialize.Architecture, Specialize.Types, Specialize.X86, Syntax, Syntax.Parse, Translate+  other-modules:  Alpha, Compile, Compile.State, Compile.Utils, Context, Context.Language, Context.Types, Elf, ID, My.Control.Monad, My.Control.Monad.State, My.Control.Monad.TimeLine, My.Data.Graph, My.Data.List, My.Data.Tree, My.Prelude, Options, PCode, PCode.Builtin, PCode.Instruction, PCode.Value, Serialize, Specialize, Specialize.Architecture, Specialize.Types, Specialize.X86, Syntax, Syntax.Parse, Translate   hs-source-dirs: src   c-sources:      src/writeElf.c
src/Alpha.hs view
@@ -50,13 +50,13 @@   progs -> mapM_ compileProgram progs   where        languageFile language = languageDir opts</>language<.>"l"-    findSource language = findM fileExist (concat [[base,base<.>"a"] | dir <- sourceDirs opts-                                                                     , let base = dir</>language])+    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-      importLanguage compileLanguage language+      importLanguage compileLanguage (const $ return ()) language       rootSym <- stateF languageF $ internSym root       getAddressComp (outputArch opts) rootSym       (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses@@ -64,11 +64,12 @@       contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size)                                         | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs]       writeElf language contents-    compileLanguage name = do-      source <- fromMaybe (fail $ "Couldn't find source file for language "++name) $< findSource name+    compileLanguage name = debugM $ do+      source <- fromMaybe (error $ "Couldn't find source file for language "++name) $< findSource name       let langFile = languageFile name       b <- doTestOlder <&&> fileExist langFile <&&> (langFile `newerThan` source)       if b then either error id $< Ser.decode $< B.readFile langFile else do +        putStrLn $ "Compiling language "++name         lang <- compileFile source         createDirectoryIfMissing True (dropFileName langFile)         B.writeFile langFile (Ser.encode lang)@@ -82,9 +83,10 @@       languageState $ modify $ \e -> exportLanguage $ e { loadCode = foldr concatCode [] code }       where compileExpr expr = print (fmap Str expr) >> do               symExpr <- languageState $ envCast expr+              print symExpr               trExpr <- doTransform symExpr               (code,imports) <- languageState $ compile Nothing trExpr-              mapM_ (importLanguage loadLanguage) imports+              mapM_ (importLanguage compileLanguage (execCode . loadCode)) imports               execCode code                return code
src/Compile/State.hs view
@@ -10,7 +10,7 @@   getSymName,getSymVal,   singleCode,   isBackEdge,-  getNodeList,getLanguage,+  getNodeList,getContext,   createEdge,deleteEdge,   createNode,deleteNode,   nullCode,nullCodeVal,@@ -23,7 +23,7 @@ import My.Control.Monad.State import My.Control.Monad import ID-import My.Data.Graph hiding (deleteEdge,deleteNode,getLanguage,Language,empty)+import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty) import Context import Context.Language as L @@ -76,7 +76,7 @@ nullCodeVal v = mkNoop >>= \n -> return (v,singleCode n)  getNodeList  = getsF depGraphF nodeList-getLanguage n = getsF depGraphF (G.getLanguage n)+getContext n = getsF depGraphF (G.getContext n)  createNode x       = stateF depGraphF (G.insertNode x) deleteNode n       = modifyF depGraphF (G.deleteNode n)
src/Compile/Utils.hs view
@@ -26,7 +26,7 @@       mapM_ (purgeNode isNoop) =<< getNodeList                mapM_ (purgeNode isEmptyBranch) =<< getNodeList     purgeNode p n = do-      c <- getLanguage n              +      c <- getContext n                     if p c then remove (n,c) else return ()     isNoop c = tag c==Instr Noop     isEmptyBranch c = case tag c of @@ -51,9 +51,9 @@       where          newStart n =            maybe (maybe [] (\c -> concat [newStart n | (n,_) <- outEdges c])-                 (lookupLanguage n old)) +                 (lookupContext n old))            (const [n])-          (lookupLanguage n new)+          (lookupContext n new)  data ANode = ANode {   weight :: Int,@@ -65,15 +65,15 @@ linearize' start depG = instrs   where      aG = annotate depG-    getLanguage n = G.getLanguage n aG-    withLanguage n = (n,getLanguage n)+    getContext n = G.getContext n aG+    withContext n = (n,getContext n)     -    isBrPart (instr . tag . getLanguage -> BrPart _) = True+    isBrPart (instr . tag . getContext -> BrPart _) = True     isBrPart _ = False     instrMap = M.fromList [(n,i) | (i,(n,_)) <- zip [0..] $ concat [map (n,) (getInstr n) | n <- concat blocks]]     instrs = concatMap (concatMap getInstr) blocks     -    getInstr (getLanguage -> c) = case tag c of+    getInstr (getContext -> c) = case tag c of       ANode { instr = BrPart v } -> [Branch v $ map branch (classesBy (===) oes)]         where branch ns = minimum $ catMaybes [M.lookup n instrMap | (n,_) <- ns]               (_,e) === (_,e') = e==e'@@ -81,17 +81,17 @@       where oes = outEdges c      selectHeads l = [n | (n,c) <- l, weight (tag c)==1]-    startHeads = selectHeads $ map withLanguage $ nub start+    startHeads = selectHeads $ map withContext $ nub start     heads = startHeads : deleteBy headsEq startHeads heads       where eq n1 n2 = if n1`elem`start then n2`elem`start else c'-              where c' = n2 `elem` [n | (n,e') <- outEdges $ getLanguage prev, e==e']-                    (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) $ find isBackEdge $ inEdges $ getLanguage n1+              where c' = n2 `elem` [n | (n,e') <- outEdges $ getContext prev, e==e']+                    (prev,e) = fromMaybe (error $ "Couldn't find edge of "++show n1++" in graph "++show aG) $ find isBackEdge $ inEdges $ getContext n1             headsEq a b = sort a==sort b             heads = classesBy eq $ selectHeads $ nodeListFull aG     tails = map (nub . concatMap saturate) heads     saturate n = if null nexts then [n] else concatMap saturate nexts-      where nexts = [n' | let c = getLanguage n                                -                        , (n',c') <- map withLanguage $ nextNodes c+      where nexts = [n' | let c = getContext n                                +                        , (n',c') <- map withContext $ nextNodes c                         , weight (tag c') > weight (tag c)]          blocks = map blockFromTails tails@@ -103,21 +103,21 @@           prevs <- mapM makeBlock (getPrevs n)           visit n           return $ concat prevs ++ [n]-        getPrevs n = map fst $ sortBy cmp $ filter p $ map withLanguage $ prevNodes language+        getPrevs n = map fst $ sortBy cmp $ filter p $ map withContext $ prevNodes language           where cmp (_,c) (_,c') = compare (erNum $ tag c') (erNum $ tag c)                 p (_,c) = weight (tag c) < weight (tag language)-                language = getLanguage n+                language = getContext n  annotate depG = newdepG   where      newdepG = mapNodes depCalc depG     depCalc (depCalc' -> (a,b)) i = ANode a b i-    depCalc' (flip G.getLanguage depG -> c)+    depCalc' (flip G.getContext depG -> c)       | any isBackEdge <||> null $ inEdges c = (1,1)       | otherwise = (1+maximum a, maximum $ zipWith (+) [0..] (reverse $ sort b))       where (a,b) = unzip [(weight t,erNum t)                            | n' <- prevNodes c-                          , let t = tag $ G.getLanguage n' newdepG]+                          , let t = tag $ G.getContext n' newdepG]                  maximum = foldl max 0
src/Context.hs view
@@ -24,6 +24,7 @@ import Specialize import PCode import ID+import Elf(entryAddress) import Syntax import Specialize.Architecture @@ -62,7 +63,7 @@  doTransform syn = gets transform >>= ($syn) -initialContext = C lang jitA M.empty 0 return+initialContext = C lang jitA M.empty entryAddress return   where (lang,jitA) = execState (mapM_ st initialBindings) (empty,M.empty)           where st (s,v) = do                   i <- stateF fstF (internSym s)
src/Context/Language.hs view
@@ -13,6 +13,7 @@ import My.Control.Monad import My.Control.Monad.State import Control.Monad.Trans+import qualified Data.Traversable as T  import ID import PCode@@ -50,20 +51,20 @@           modifyF symsF (BM.insert s i)             return i -envCast t = traverseM (state . intern) t+envCast t = T.mapM (state . intern) t   where intern "?" = createSym         intern str = internSym str               -importLanguage :: MonadState Context m => (String -> m Language) -> String -> m ()-importLanguage getImport imp = merge imp+importLanguage getImport loadImport imp = merge imp   where -    getImp imp = do+    merge imp = gets language >>= \l -> unless (imp`isImport`l) $ do       l' <- getImport imp       mapM_ merge [imp | (imp,_) <- BM.toList (modMap l')]-      return l'-    merge imp = gets language >>= \l -> if imp`isImport`l then return () else getImp imp >>= \l' -> doF languageF $ do-      let syms' = symMap l' ; mods' = modMap l' ; mi' = maxID l'-      mapM (state . internSym) (BM.keys syms')+      mergeLanguage l'+      loadImport l'+    mergeLanguage l' = doF languageF $ do+      let Language { symMap = syms' , modMap = mods' , maxID = mi' } = l'+      mapM_ (state . internSym) $ BM.keys syms'       Language { maxID = mi, symMap = syms } <- get       let aliases = [(i'+mi,fromJust $ BM.lookup s' syms)                      | (s',i') <- BM.toList syms']@@ -95,16 +96,15 @@   loadCode = translate trans (loadCode e)   }   where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined))-        ex = exports e ; eqs = equivMap e+        Language { exports = ex, equivMap = eqs } = e         vals' = M.map (translate trans) $ M.intersection (valMap e) (set2Map ex)         trans s = fromMaybe s $ M.lookup s eqs         refs = S.fromList $ concatMap references $ M.elems vals'         exportNameP _ s = (S.member s ex || S.member s refs)                           && not (M.member s eqs)-        references val = case val of-          Verb code -> codeRefs code -          Noun size init -> codeRefs size ++ codeRefs init-          _ -> []+        references (Verb code) = codeRefs code +        references (Noun size init) = codeRefs size ++ codeRefs init+        references _ = []  -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com> -- All rights reserved.
src/Elf.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-}-module Elf (writeElf) where+module Elf (writeElf,entryAddress) where  import Foreign import Foreign.C@@ -10,7 +10,9 @@  foreign import ccall "writeElf"    c_writeElf :: CInt -> Ptr CChar -> CInt -> IO ()-              +foreign import ccall "entryAddress"+  entryAddress :: Int+                 outFileMode = ownerModes + groupReadMode + groupExecuteMode + otherReadMode + otherExecuteMode   where (+) = unionFileModes
src/My/Control/Monad.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM,traverseM) where+module My.Control.Monad (module Control.Monad,($<),(>$),(>$<),(§),(§<),(>§),(>§<),(<&&>),(<||>),ifM,findM) where  import Control.Monad-import Data.Traversable-import Control.Applicative  ($<)  :: Monad m => (a -> b) -> m a -> m b (>$)  :: Monad m => m (a -> b) -> a -> m b@@ -20,11 +18,11 @@ ifM b th el = b >>= \b -> if b then th else el a <&&> b = ifM a b (return False) a <||> b = ifM a (return True) b+infixr 3 <&&>+infixr 3 <||>  findM p l = foldr fun (return Nothing) l   where fun x ret = ifM (p x) (return $ Just x) ret--traverseM f = unwrapMonad . traverse (WrapMonad . f)  -- Copyright (c) 2012, Coiffier Marc <marc.coiffier@gmail.com> -- All rights reserved.
src/My/Data/Graph.hs view
@@ -1,8 +1,8 @@ module My.Data.Graph( -  Language,Graph,Node(..),+  Graph,Node(..),      empty,-  lookupLanguage,getLanguage,+  lookupContext,getContext,   insertNode,deleteNode,modifyNode,   insertEdge,deleteEdge,   @@ -21,24 +21,24 @@ import Data.Maybe  type Node = Int-data Language e n = Language { +data Context e n = Context {    nodeTag :: n,    nodeInEdges :: M.Map Node e,    nodeOutEdges :: M.Map Node e   } deriving Show data Graph e n = Graph {   nbNodes :: Int,-  graphNodes :: M.Map Node (Language e n)+  graphNodes :: M.Map Node (Context e n)   }                   empty = Graph 0 M.empty -lookupLanguage n (Graph _ nds) = M.lookup n nds-getLanguage n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupLanguage n g+lookupContext n (Graph _ nds) = M.lookup n nds+getContext n g = fromMaybe (error $ "No node "++show n++" in graph "++show g) $ lookupContext n g -insertNode x (Graph n nds)       = (n,Graph (n+1) (M.insert n (Language x M.empty M.empty) nds))+insertNode x (Graph n nds)       = (n,Graph (n+1) (M.insert n (Context x M.empty M.empty) nds)) deleteNode nd (Graph n nds)      = Graph n (M.delete nd nds)-modifyNode nd f (Graph n nds)    = Graph n (M.adjust (\(Language t i o) -> Language (f t) i o) nd nds)+modifyNode nd f (Graph n nds)    = Graph n (M.adjust (\(Context t i o) -> Context (f t) i o) nd nds)  insertEdge x n1 n2 (Graph n nds) = Graph n (M.adjust (modifyInEdges (M.insert n1 x)) n2 $                                             M.adjust (modifyOutEdges (M.insert n2 x)) n1 nds) @@ -59,14 +59,12 @@ nodeList = map fst . nodeListFull nodeListFull = M.toList . graphNodes -mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Language t ie oe) -> Language (f n t) ie oe) nds)+mapNodes f (Graph n nds) = Graph n (M.mapWithKey (\n (Context t ie oe) -> Context (f n t) ie oe) nds) -instance Functor (Graph e) where-  fmap f = mapNodes (const f) instance (Show n,Show e) => Show (Graph e n) where   show (Graph _ nds) = intercalate "\n" showNodes     where showNodes = map showNode $ M.toList nds-          showNode (n,Language nd ie oe) = +          showNode (n,Context nd ie oe) =              show n++": "++show nd++"\n  "++             intercalate "\n  " (map showNEdge (M.toList oe)                                 ++ map showREdge (M.toList ie))
+ src/My/Data/Tree.hs view
@@ -0,0 +1,15 @@+module My.Data.Tree(module Data.Tree+                   ,nubT,iterateT+                   ,spanningTree) where++import Data.Tree+import 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)]) +iterateT seed f = unfoldTree (\a -> (a,f a)) seed++spanningTree seed nexts = nubT $ iterateT seed nexts
src/My/Prelude.hs view
@@ -7,6 +7,7 @@ import My.Control.Monad  debug x = traceShow x x+debugM m = m >>= \x -> return (debug x)  maybeToEither = maybe (Left undefined) Right eitherToMaybe = either (const Nothing) Just
src/PCode/Instruction.hs view
@@ -5,7 +5,7 @@ import Data.List import Data.Maybe import Data.Array-import Data.Tree+import My.Data.Tree import qualified Data.Set as S import PCode.Builtin import PCode.Value@@ -59,10 +59,6 @@         nexts n = [n+1]         prevs n = accumArray (flip (:)) [] bs [(n,i) | i <- [bMin..bMax], n <- nexts i] ! n -spanningTree seed nexts = evalState (unfoldTreeM unfold seed) S.empty-  where unfold seed = do modify (S.insert seed) ; s <- get -                         return (seed,[n | n <- nexts seed, not $ S.member n s])-             spanArray bs tree = array bs (assocs Nothing tree)   where assocs p (Node a subs) = (a,(p,map rootLabel subs)):concatMap (assocs (Just a)) subs codeRefs (Code args code ret) = refs code (bindSyms ret++concatMap bindSyms args)
src/Specialize.hs view
@@ -7,5 +7,11 @@ import ID import Data.ByteString +retCode = ret+  where ret = [0xc3]+        exit = [0x31,0xdb+               ,0x31,0xc0, 0xff,0xc0+               ,0xcd,0x80]        + specialize :: Monad m => Architecture -> (ID -> m Int) -> Code -> (Int,m ByteString)-specialize arch assoc (Code args code ret) = (1,return $ pack [0xC3])+specialize arch assoc (Code args code ret) = (Prelude.length retCode,return $ pack retCode)
src/Specialize/Architecture.hs view
@@ -13,10 +13,10 @@   show a = "#<Arch:"++archName a++">"  architectures = [hostArch,arch_x86,arch_x86_64,arch_arm]-nullArch = Arch undefined undefined undefined undefined-arch_x86 = nullArch { archName = "x86" }-arch_x86_64 = nullArch { archName = "x86_64" }-arch_arm = nullArch { archName = "arm" }+nullArch = Arch undefined undefined undefined undefined undefined+arch_x86 = nullArch { archName = "x86", archDefaultSize = 4 }+arch_x86_64 = nullArch { archName = "x86_64", archDefaultSize = 8 }+arch_arm = nullArch { archName = "arm", archDefaultSize = 4 }  hostArch = arch_x86_64 { archName = "host" }
src/Specialize/Types.hs view
@@ -1,14 +1,16 @@+{-# LANGUAGE RankNTypes #-} module Specialize.Types(   module Data.Word, module My.Control.Monad.TimeLine,-  module PCode.Instruction, module ID,+  module PCode, module ID,   Register(..),Address(..),    Architecture(..),    Past(..),Future(..),   Allocate(..)) where +import Data.ByteString import Data.Word import My.Control.Monad.TimeLine-import PCode.Instruction+import PCode import ID import Data.Map import Data.Set@@ -16,14 +18,15 @@ type Register = Int type Address = (Maybe ID,Int) data Architecture = Arch {-  archName         :: String,-  archInitialPast  :: [BindVar] -> Past,-  archFinalFuture  :: Future,-  archCompileInstr :: Instruction -> (Int -> ((Int,Int),Past)) -> Allocate (Int,[Word8])+  archName           :: String,+  archDefaultSize    :: Int,+  archInitialPast    :: [BindVar] -> Past,+  archCompileCase    :: [Int] -> (Int -> ((Int,Int),Past)) -> AllocInstr,+  archCompileBuiltin :: Builtin -> ID -> [Value] -> AllocInstr   } data Past = Past {    addresses :: Map ID Address,-  bindings  :: Maybe (Map ID Register),+  bindings  :: Map ID Register,   clobber   :: Map ID [ID],   stack     :: [(Bool,Int)]   }@@ -31,3 +34,4 @@   fregs :: Map ID Register   } type Allocate = TimeLine Past Future+type AllocInstr = Monad m => Allocate (Int,m ByteString)
src/writeElf.c view
@@ -2,47 +2,49 @@ #include <libelf.h>  #define SETSTRUCT(v,t,vals...) { t tmp = vals; v = tmp; }+#define H_SIZE (sizeof(Elf64_Ehdr)+sizeof(Elf64_Phdr))+#define ENTRY (H_SIZE+(1<<21))  typedef unsigned char byte; -void writeElf(int fd,byte* data,int dataSize);+int entryAddress() { return ENTRY; } + void writeElf(int fd,byte* data,int dataSize) {    Elf64_Ehdr eh;    Elf64_Phdr pht[1];-   unsigned int hSize = sizeof(eh) + sizeof(pht); -   SETSTRUCT(eh,Elf64_Ehdr,-             {-                .e_ident = { -                   ELFMAG0, ELFMAG1, ELFMAG2, ELFMAG3,-                   ELFCLASS64, ELFDATA2LSB,-                   EV_CURRENT,-                   ELFOSABI_NONE, 0,-                   0-                },-                   .e_type      = ET_EXEC,-                       .e_machine   = EM_X86_64,-                       .e_version   = EV_CURRENT,-                       .e_entry     = 0,-                       .e_phoff     = sizeof(Elf64_Ehdr),-                       .e_shoff     = 0,-                       .e_flags     = 0,-                       .e_ehsize    = sizeof(Elf64_Ehdr),-                       .e_phentsize = sizeof(Elf64_Phdr),-                       .e_phnum     = 2,-                       .e_shentsize = 0,-                       .e_shnum     = 0,-                       .e_shstrndx  = SHN_UNDEF-                       });-   SETSTRUCT(pht[0],Elf64_Phdr,{ .p_type   = PT_LOAD,-            .p_offset = hSize,-            .p_vaddr  = 0,-            .p_paddr  = 0,-            .p_filesz = dataSize,-            .p_memsz  = dataSize,-            .p_flags  = PF_R | PF_W | PF_X,-            .p_align  = 1-               });+   SETSTRUCT(eh,Elf64_Ehdr,{+      .e_ident = { +         ELFMAG0, ELFMAG1, ELFMAG2, ELFMAG3,+         ELFCLASS64, ELFDATA2LSB,+         EV_CURRENT,+         ELFOSABI_NONE, 0,+         0+      },+      .e_type      = ET_EXEC,+      .e_machine   = EM_X86_64,+      .e_version   = EV_CURRENT,+      .e_entry     = ENTRY,+      .e_phoff     = sizeof(Elf64_Ehdr),+      .e_shoff     = 0,+      .e_flags     = 0,+      .e_ehsize    = sizeof(Elf64_Ehdr),+      .e_phentsize = sizeof(Elf64_Phdr),+      .e_phnum     = 1,+      .e_shentsize = 0,+      .e_shnum     = 0,+      .e_shstrndx  = SHN_UNDEF+   });+   SETSTRUCT(pht[0],Elf64_Phdr,{ +      .p_type   = PT_LOAD,+      .p_offset = H_SIZE,+      .p_vaddr  = ENTRY,+      .p_paddr  = 0,+      .p_filesz = dataSize,+      .p_memsz  = dataSize,+      .p_flags  = PF_R | PF_W | PF_X,+      .p_align  = 1<<21+   });         write(fd,&eh,sizeof(eh));    write(fd,&pht,sizeof(pht));