packages feed

alpha 1.0.10 → 1.0.11

raw patch · 7 files changed

+39/−34 lines, 7 files

Files

alpha.cabal view
@@ -1,5 +1,5 @@ name:           alpha-version:        1.0.10+version:        1.0.11 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
@@ -75,33 +75,44 @@   mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (parseAlpha "/dev/stdin" str)   putStrLn "\rGoodbye !" compileProgram (language,entryName) = withInitialContext $ do-  importLanguage compileLanguage (const $ return ()) language+  importLanguage (const $ return ()) language   entrySym <- viewState language_ $ internSym entryName-  _ <- getAddressComp (outputArch ?settings) entrySym-  (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses-  top <- gets compTop-  contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size)+  tagIO ("Linking program "++entryName) $ do+    _ <- getAddressComp (outputArch ?settings) entrySym+    (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses+    top <- gets compTop+    contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size)                                    | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs]-  writeFormat (outputFmt ?settings) entryName contents+    writeFormat (outputFmt ?settings) entryName contents+modTime f = modificationTime $< getFileStatus f compileLanguage force name = do   let langFile = languageFile name       newerThan f1 f2 = liftM2 (>=) (modTime f1) (modTime f2)-        where modTime f = modificationTime $< getFileStatus f-   source <- findSource name   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++"..."-         lang <- compileFile $ fromMaybe (error $ "Couldn't find source file for language "++name) source-         createDirectoryIfMissing True (dropFileName langFile)-         B.writeFile langFile (Ser.encode lang)-         return lang-  return (not skip,l)+         tagIO ("Compiling language "++name) $ do+           lang <- compileFile $ fromMaybe (error $ "Couldn't find source file for language "++name) source+           createDirectoryIfMissing True (dropFileName langFile)+           B.writeFile langFile (Ser.encode lang)+           return lang+  time <- modTime langFile+  return (time,l)     where compileFile src = withInitialContext $ do             str <- readFile src             inits <- mapM compileExpr (parseAlpha src str)             getting (language_ >>> f_ (purgeLanguage >>> (,inits)))+importLanguage loadImport = import'+  where import' lang = gets language >>= \l -> ifThenElse (lang`isImport`l) (modTime $ languageFile lang) $ do+          node@(time,(l',_)) <- compileLanguage False lang+          times <- mapM import' (getImports l')+          node <- if time < foldl max time times then compileLanguage True lang else return node+          let (time,(l'',init)) = node+              l' = l''{ nameL = lang }+          init' <- viewing language_ $ modify (<>l') >> gets (translateInit init l')+          loadImport init'+          return time compileExpr expr = do   expr <- doTransform =<< viewing language_ (envCast expr)   code <- viewing language_ $ compile [] Nothing expr@@ -195,12 +206,12 @@ ALPHA_EXPORT(import,ID -> IO()) sym = withSettings $ do   name <- getting (language_ >>> f_ (lookupSymName sym))   void $ case name of-    Just name -> importLanguage compileLanguage (mapM_ runSym) name+    Just name -> importLanguage (mapM_ runSym) name     Nothing -> error $ "Symbol "++show sym++" has no name." ALPHA_EXPORT(reload,IO()) = withSettings $ do   imports <- getting (language_ >>> f_ (languagesL >>> BM.toList >>> map fst))    put initialContext-  mapM_ (importLanguage compileLanguage (mapM_ runSym)) imports+  mapM_ (importLanguage (mapM_ runSym)) imports  compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context)
src/Compile/State.hs view
@@ -62,7 +62,9 @@ newVar      = lift $ state createSym  pushInfo        = modifying infoStack_ . (:)-popInfo         = viewState infoStack_ (\(h:t) -> (h,t))+popInfo         = viewState infoStack_ (\l -> case l of+                                           (h:t) -> (h,t)+                                           [] -> error "Invalid use of Axioms <- or -> outside of a choose expression") topInfo         = getting (infoStack_ >>> f_ head) withTopInfo i x = pushInfo i >> x >>= \v -> popInfo >> return v withInfo f      = popInfo >>= \i -> f i >>= \ret -> pushInfo i >> return ret
src/Context/Language.hs view
@@ -29,6 +29,7 @@     showTable "Values" (\(i,v) -> [show i++" -> "++show v]) $ M.toList (valuesL e),     ["Exports: "++show (exportsL e)]] +translateInit init l' l = translate (translateFromSub l' l) init translateFromSub l' l = \s' -> fromMaybe (tr s') $ M.lookup (tr s') (aliasesL l)   where tr s' = fromMaybe (s' + mi) $ do           m <- lookupSymMod s' l'@@ -78,19 +79,6 @@ envCast t = T.mapM (state . intern) t   where intern "?" = createSym         intern str = internSym str--importLanguage getImport loadImport imp = merge imp-  where -    merge imp = gets language >>= \l -> ifThenElse (imp`isImport`l) (return False) $ do-      (contents,(comp,recomp)) <- tryCompile False imp-      (l',init) <- if not comp && recomp then fst $< tryCompile True imp else return contents-      init' <- viewing language_ $ modify (<>l') >> gets (\l -> translate (translateFromSub l' l) init)-      loadImport init'-      return $ comp || recomp-    tryCompile force imp = do-      (comp,(l',init)) <- getImport force imp-      comps <- mapM merge (getImports l')-      return ((l'{ nameL = imp },init),(comp,or comps))  set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined)) purgeLanguage l = mempty {
src/My/Control/Monad.hs view
@@ -3,8 +3,7 @@                         ,($<),(>$),(>$<)                         ,(§),(§<),(>§),(>§<)                          ,(<&&>),(<||>)-                         ,ifM,findM-                         ,lift2+                         ,ifM,findM,prog1                          ,doNothing) where  import Control.Monad@@ -31,6 +30,8 @@ a <||> b = ifM a (return True) b infixr 3 <&&> infixr 3 <||>++prog1 a b = a >>= \x -> b >> return x  findM p l = foldr fun (return Nothing) l   where fun x ret = ifM (p x) (return $ Just x) ret
src/My/Prelude.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module My.Prelude where +import My.Control.Monad import Debug.Trace as Tr import qualified Data.ByteString as B import Data.Char@@ -21,3 +22,4 @@ showHex n = reverse $ map (intToDigit . fromIntegral . (`mod`16)) $ take 2 $ iterate (`div`16) (n :: Word8) showCode code = intercalate " " $ map showHex $ B.unpack $ code +tagIO tag m = prog1 (putStr (tag++"...") >> m) (putStrLn "done.")
src/Specialize/X86_64.hs view
@@ -324,7 +324,8 @@   | b`elem`[BSet,BSetSX,BNot,BSub] && varSize d<=defSize = withFreeSet $ do     [v] <- loadArgs [(s,Nothing)]     readFuture $ do-      let dest r = maybe (destRegister d) (const $ return r) $ mfilter (not . isActive) $ valSym s+      let dest r | maybe False (not . isActive) (valSym s) = return r+                 | otherwise = destRegister d       r' <- dest $ (id ||| const 0) v        (mov r' <|||> movi r') v       when (argSize s < varSize d) $ case () of