alpha 1.0.1 → 1.0.2
raw patch · 4 files changed
+43/−30 lines, 4 files
Files
- alpha.cabal +1/−1
- src/Alpha.hs +25/−18
- src/Context.hs +15/−8
- src/Specialize.hs +2/−3
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 1.0.1+version: 1.0.2 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
@@ -5,6 +5,7 @@ import Data.List import Data.Maybe import Data.Ord+import Data.Version import qualified Data.Bimap as BM import qualified Data.ByteString as B import qualified Data.Map as M@@ -15,11 +16,13 @@ import My.Control.Monad.State hiding ((<.>)) import My.Prelude import Options+import Paths_alpha (version) import PCode import Serialize import Specialize import Syntax import Syntax.Parse+import System.IO import System.Directory import System.Environment as SE import System.FilePath@@ -39,9 +42,8 @@ formatEntry Elf64 = entryAddress formatEntry (Raw n) = n -version = "1.0" printHelp = putStrLn helpMsg-printVersion = putStrLn $ "Alpha version "++version+printVersion = putStrLn $ "Alpha version "++showVersion version newtype Str = Str String instance Show Str where show (Str s) = s@@ -52,10 +54,16 @@ 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])+ findSource language = findM doesFileExist [file | dir <- sourceDirs opts+ , let base = dir</>language+ , file <- [base<.>"a",base]] - interactive = void $ compileFile "/dev/stdin"+ interactive = withDefaultContext entry $ do+ putStrLn $ "Alpha, version "++showVersion version++". Type alpha/help() for help on Alpha invocation. ^D to exit."+ str <- getContents+ let sTree = concat $ parseAlpha "/dev/stdin" str+ mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree)+ putStrLn "\rGoodbye !" compileProgram (language,root) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language l <- viewing language_ get@@ -80,17 +88,16 @@ B.writeFile langFile (Ser.encode lang) return lang return (not skip,l)-- 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- symExpr <- languageState $ envCast expr- trExpr <- doTransform symExpr- (code,imports) <- languageState $ compile [] Nothing trExpr- mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports- execCode code- return code+ where 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 }+ compileExpr expr = do+ symExpr <- languageState $ envCast expr+ trExpr <- doTransform symExpr+ (code,imports) <- languageState $ compile [] Nothing trExpr+ mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports+ execCode code+ return code
src/Context.hs view
@@ -6,31 +6,32 @@ ,doTransform ,getAddressComp ,execCode) where -import Bindings.Posix.Unistd import Bindings.Posix.Sys.Mman-import Context.Language as Lang+import Bindings.Posix.Unistd import Context.Language+import Context.Language as Lang import Context.Types-import qualified Data.ByteString as B-import Data.ByteString.Unsafe import Data.ByteString.Internal+import Data.ByteString.Unsafe import Data.Functor.Identity import Data.IORef import Data.Maybe-import qualified Data.Map as M import Elf(entryAddress)+import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import Foreign.C import Foreign.ForeignPtr.Unsafe-import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import ID import My.Control.Monad import My.Control.Monad.State+import My.Prelude+import Options import PCode import Specialize import Specialize.Architecture import Syntax import System.IO.Unsafe (unsafePerformIO)-import My.Prelude+import qualified Data.ByteString as B+import qualified Data.Map as M foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt @@ -43,7 +44,7 @@ funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int)-contextRef = unsafePerformIO $ newIORef (undefined :: Context)+contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) instance MonadState Context IO where get = readIORef contextRef put = writeIORef contextRef@@ -87,6 +88,9 @@ foreign import ccall "&free_" free_ptr :: FunPtr (Ptr() -> IO ()) free_ = free +foreign export ccall "printHelp_" printHelp_ :: IO ()+foreign import ccall "&printHelp_" printHelp_ptr :: FunPtr (IO ())+printHelp_ = Prelude.putStrLn helpMsg foreign export ccall "printOK_" printOK_ :: IO () foreign import ccall "&printOK_" printOK_ptr :: FunPtr (IO ()) printOK_ = Prelude.putStrLn "OK"@@ -94,6 +98,8 @@ foreign import ccall "&printNum_" printNum_ptr :: FunPtr (Int -> IO ()) printNum_ n = print (intPtrToPtr $ fromIntegral n) ++ initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ ("alter" ,Left $ Axiom XAlter), ("bind" ,Left $ Axiom XBind),@@ -122,6 +128,7 @@ ("alpha/allocate" , Right $ exportAlpha callStub1 allocate_ptr), ("alpha/free" , Right $ exportAlpha callStub1 free_ptr), + ("alpha/help" , Right $ exportAlpha callStub1 printHelp_ptr), ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) ]
src/Specialize.hs view
@@ -27,7 +27,6 @@ import System.IO.Unsafe import My.Prelude-import Debug.Trace worldID = ID (-1) @@ -53,10 +52,10 @@ where getsi f = gets $ \a i -> f (a!i) puti i e = modify $ (//[(i,e)])- nextFuture i f = snd4 $ runInstr i undefined f (const Nothing)+ nextFuture i f = snd4 $ runInstr i (error "undefined past") f (const Nothing) gens = array bounds $ zip (flatten codeTree) [0..] gens' = array bounds $ zip [0..] (flatten codeTree)- getPast g i | g == maximum (filter (<=(gens!i)) $ map (gens!) $ prevs i) = Nothing+ getPast g i | (case filter (<=(gens!i)) [gens!j | j <- prevs i] of [] -> False ; l -> g==maximum l) = Nothing | otherwise = Just $ fst $ instrs!i instrs = array bounds $ flatten $ descend desc past codeTree where desc i p = ((i,(p,c)),p')