packages feed

alpha 0.995 → 0.999

raw patch · 5 files changed

+70/−28 lines, 5 files

Files

alpha.cabal view
@@ -1,5 +1,5 @@ name:           alpha-version:        0.995+version:        0.999 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
@@ -36,7 +36,7 @@   PrintVersion -> printVersion   Compile -> doCompile s -version = "0.995"+version = "0.999" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version
src/Context.hs view
@@ -11,7 +11,7 @@ import Context.Language as Lang import Context.Language import Context.Types-import Data.ByteString hiding (map,putStrLn)+import qualified Data.ByteString as B import Data.ByteString.Unsafe import Data.ByteString.Internal import Data.Functor.Identity@@ -34,24 +34,32 @@  foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt +foreign import ccall "dynamic" mkProc :: FunPtr (Ptr() -> IO ()) -> Ptr() -> IO ()+foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int+foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO ()+foreign import ccall "dynamic" mkFunTransform :: FunPtr (Ptr () -> Ptr() -> IO (Ptr ())) -> Ptr() -> Ptr () -> IO (Ptr ())+ withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x+funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f +addressRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) contextRef = unsafePerformIO $ newIORef (undefined :: Context) instance MonadState Context IO where   get = readIORef contextRef   put = writeIORef contextRef -funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f- exportAlpha stub ptr = unsafePerformIO $ do   unsafeUseAsCStringLen (stub $ funPtrToInteger ptr) $ \(src,size) -> do     ptr <- mallocForeignPtrBytes size     withForeignPtr ptr $ \dst -> copyBytes (castPtr dst) src size     return ptr +foreign export ccall "setTransform_" setTransform_ :: Ptr () -> IO ()+foreign import ccall "&setTransform_" setTransform_ptr :: FunPtr (Ptr () -> IO ())+setTransform_ fun = modify $ \c -> c { transform = Just fun }+ foreign export ccall "address_" address_ :: ID -> IO Int foreign import ccall "&address_" address_ptr :: FunPtr (ID -> IO Int)-addressRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) address_ id = readIORef addressRef >>= ($id)  foreign export ccall "symName_" symName_ :: ID -> IO (Ptr Word8)@@ -61,6 +69,12 @@   ret <- newArray0 0 (map c2w $ fromMaybe "" n)   return ret +foreign export ccall "nameSym_" nameSym_ :: Ptr Word8 -> IO ID+foreign import ccall "&nameSym_" nameSym_ptr :: FunPtr (Ptr Word8 -> IO ID)+nameSym_ p = do+  l <- peekArray0 0 p+  stateF languageF (internSym $ map w2c l)+   foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ()) foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ())) allocate_ = mallocBytes@@ -88,16 +102,47 @@   ("id"     ,Left $ Axiom XID),   ("@"      ,Left $ Axiom XAddr),   ("#"      ,Left $ Axiom XSize)] ++ [-  ("alpha/c@"          , Right $ exportAlpha callStub1 address_ptr),    -  ("alpha/symbol-name" , Right $ exportAlpha callStub1 symName_ptr),    -  ("alpha/allocate"    , Right $ exportAlpha callStub1 allocate_ptr), -  ("alpha/print-OK"    , Right $ exportAlpha callStub0 printOK_ptr),    -  ("alpha/print-num"   , Right $ exportAlpha callStub1 printNum_ptr)  -  ] -doTransform syn = gets transform >>= ($syn)+  ("alpha/c@"            , Right $ exportAlpha callStub1 address_ptr),    +  ("alpha/symbol-name"   , Right $ exportAlpha callStub1 symName_ptr),+  ("alpha/name-symbol"   , Right $ exportAlpha callStub1 nameSym_ptr),+  ("alpha/set-transform" , Right $ exportAlpha callStub1 setTransform_ptr),    +  ("alpha/allocate"      , Right $ exportAlpha callStub1 allocate_ptr), +  ("alpha/print-OK"      , Right $ exportAlpha callStub0 printOK_ptr),    +  ("alpha/print-num"     , Right $ exportAlpha callStub1 printNum_ptr) -initialContext = C lang jitA M.empty (fromIntegral entryAddress) return+  ]++doTransform syn = gets transform >>= ($syn) . maybe return tr +  where tr fun tree = do+          root <- allocTree tree+          new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root+          readTree new+        intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr())+        pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e)+        pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e)+        allocTree (Group g) = do+          p <- mallocBytes (intS+intS+(length g*ptrS))+          p' <- pok (0::Int) p+          p'' <- pok (length g) p'+          mapM allocTree g >>= \l -> pokeArray (castPtr p'') l+          return p+        allocTree (Symbol (ID s)) = do+          p <- mallocBytes (intS+intS)+          p' <- pok (1::Int) p+          pok s p'+          return p+        readTree p = do+          (t,p') <- pik p+          case t :: Int of+            0 -> do+              (s,p'') <- pik p'+              l <- peekArray s p''+              liftM Group $ mapM readTree l+            1 -> do+              liftM (Symbol . ID) $ peek p'+              +initialContext = C lang jitA M.empty (fromIntegral entryAddress) Nothing   where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty)           where st (s,v) = do                   i <- stateF fstF (internSym s)@@ -110,15 +155,19 @@ contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a languageState = contextState . doF languageF -foreign import ccall "dynamic" mkProc :: FunPtr (Ptr() -> IO ()) -> Ptr() -> IO ()-foreign import ccall "dynamic" mkFunSize :: FunPtr (Ptr() -> IO Int) -> Ptr() -> IO Int-foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO ()- pageSize = fromIntegral $ unsafePerformIO $ c'sysconf c'_SC_PAGESIZE enableExec p size = do   let p' = alignPtr (p`plusPtr`(1-pageSize)) pageSize   mprotect (castPtr p') (fromIntegral $ size+ p`minusPtr`p') (c'PROT_READ .|. c'PROT_WRITE .|. c'PROT_EXEC)   +evalCode :: (FunPtr (Ptr() -> a) -> Ptr() -> a) -> ByteString -> Code -> (a -> IO b) -> IO b+evalCode wrap stub code f = do+  id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i+  p <- getAddressJIT id+  unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) +execCode [] = return ()+execCode instrs = evalCode mkProc execStub (Code [] instrs (symBind (ID (-1)))) id+ getAddress arch lookup register = withRef addressRef getAddr . getAddr   where     getAddr sym = lookup sym >>= \val -> case val of@@ -138,14 +187,6 @@           register sym ptr size           withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p)         _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang)--evalCode :: (FunPtr (Ptr() -> a) -> Ptr() -> a) -> ByteString -> Code -> (a -> IO b) -> IO b-evalCode wrap stub code f = do-  id <- languageState $ state createSym >>= \i -> modify (setSymVal i (Verb code)) >> return i-  p <- getAddressJIT id-  unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) -execCode [] = return ()-execCode instrs = evalCode mkProc execStub (Code [] instrs (symBind (ID (-1)))) id  getAddressJIT = getAddress hostArch lookup register   where lookup id = do
src/Context/Types.hs view
@@ -1,6 +1,7 @@ module Context.Types where  import Foreign.ForeignPtr+import Foreign.Ptr import Data.Word import Data.Bimap import Data.Map@@ -41,7 +42,7 @@   jitAddresses  :: Map ID (ForeignPtr Word8),   compAddresses :: Map ID (Int,ForeignPtr Word8),   compTop       :: Int,-  transform     :: Syntax ID -> IO (Syntax ID)+  transform     :: Maybe (Ptr ())   } jitAddressesF  = Field (jitAddresses,\a c -> c { jitAddresses = a }) compAddressesF = Field (compAddresses,\a c -> c { compAddresses = a })
src/Specialize.hs view
@@ -96,7 +96,7 @@                                                        <> S.fromList (catMaybes [root i s | SymVal t s <- SymVal Address v:vs                                                                                           , t==Value || t==Address])                             addActives (Branch (SymVal Value id) _) s = s <> clobbers i id -                            addActives (Bind _ v) s = maybe id S.insert v s+                            addActives (Bind bv v) s = maybe id S.insert v $ s S.\\ S.fromList (bindSyms bv)                             addActives _ s = s             localsA = treeArray next (S.fromList [v | bv <- retVar:args, v <- bindSyms bv])               where next _ s (Bind bv _) = s `S.union` S.fromList (bindSyms bv)