alpha 0.9999 → 0.99999
raw patch · 7 files changed
+39/−26 lines, 7 files
Files
- alpha.cabal +1/−1
- src/Alpha.hs +2/−1
- src/Compile/Utils.hs +1/−1
- src/Context.hs +18/−8
- src/Specialize.hs +10/−8
- src/Specialize/Architecture.hs +1/−1
- src/Specialize/X86_64.hs +6/−6
alpha.cabal view
@@ -1,5 +1,5 @@ name: alpha-version: 0.9999+version: 0.99999 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.9999"+version = "0.99999" printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++version @@ -85,6 +85,7 @@ 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/Utils.hs view
@@ -29,7 +29,7 @@ let m' = foldr (uncurry M.insert) m (zip (bindSyms bv) news) return (Bind (translate (translateBy m') bv) (fmap (translateBy m) v),m') uniq i m = return (onF fstF (translate (translateBy m)) $ withLocals m $ instr i)- localVal m (SymVal Value s) | not $ M.member s m = SymVal GValue s+ 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)
src/Context.hs view
@@ -42,7 +42,7 @@ 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)+compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) contextRef = unsafePerformIO $ newIORef (undefined :: Context) instance MonadState Context IO where get = readIORef contextRef@@ -58,9 +58,9 @@ 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)-address_ id = readIORef addressRef >>= ($id)+foreign export ccall "compAddr_" compAddr_ :: ID -> IO Int+foreign import ccall "&compAddr_" compAddr_ptr :: FunPtr (ID -> IO Int)+compAddr_ id = readIORef compAddrRef >>= ($id) foreign export ccall "symName_" symName_ :: ID -> IO (Ptr Word8) foreign import ccall "&symName_" symName_ptr :: FunPtr (ID -> IO (Ptr Word8))@@ -68,16 +68,21 @@ n <- gets (lookupSymName sym . language) 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 "createSym_" createSym_ :: IO ID+foreign import ccall "&createSym_" createSym_ptr :: FunPtr (IO ID)+createSym_ = stateF languageF createSym+ foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ()) foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ())) allocate_ = mallocBytes+foreign export ccall "free_" free_ :: Ptr() -> IO ()+foreign import ccall "&free_" free_ptr :: FunPtr (Ptr() -> IO ())+free_ = free foreign export ccall "printOK_" printOK_ :: IO () foreign import ccall "&printOK_" printOK_ptr :: FunPtr (IO ())@@ -103,11 +108,16 @@ ("@" ,Left $ Axiom XAddr), ("#" ,Left $ Axiom XSize)] ++ [ - ("alpha/c@" , Right $ exportAlpha callStub1 address_ptr), + ("alpha/c@" , Right $ exportAlpha callStub1 compAddr_ptr), + ("alpha/create-symbol" , Right $ exportAlpha callStub0 createSym_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/free" , Right $ exportAlpha callStub1 free_ptr), + ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) @@ -167,7 +177,7 @@ unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) execCode c = evalCode mkProc execStub c id -getAddress arch lookup register = withRef addressRef getAddr . getAddr+getAddress arch lookup register = withRef compAddrRef getAddr . getAddr where getAddr sym = lookup sym >>= \val -> case val of Just a -> return a
src/Specialize.hs view
@@ -92,17 +92,19 @@ fun i a = (addActives (instr i) out,out) where out = S.unions (map ((a!) >>> fst) (nexts i)) addActives (Op _ v vs) s = (s S.\\ clobbers i v)- <> S.unions [clobbers i s | SymVal Value s <- vs]- <> S.fromList (catMaybes [root i s | SymVal t s <- SymVal Address v:vs+ <> S.fromList [s | SymVal Value s <- vs]+ <> S.fromList (catMaybes [root i s | SymVal t s <- SymVal Value v:vs , t==Value || t==Address])- addActives (Branch (SymVal Value id) _) s = s <> clobbers i id + addActives (Branch (SymVal Value id) _) s = S.insert id s addActives (Bind bv v) s = maybe id S.insert v $ s S.\\ S.fromList (bindSyms bv) addActives _ s = s clobbers i v = fromMaybe (S.singleton v) $ R.lookupRan v (clobbersA!i)- clobbersA = treeArray next (foldl (next undefined) R.empty [Bind bv Nothing | bv <- maybe id (:) retVar args])+ clobbersA = treeArray next (insertManyA (R.singleton worldID worldID)+ [(bindSym bv,s) | bv <- maybe id (:) retVar args+ , bv <- bindNodes bv+ , s <- bindSyms bv]) where next i r (Bind bv v) = insertManyA r assocs- where assocs = [(bindSym bv,s) | bv <- bindNodes bv- , s <- bindSyms bv]+ where assocs = [(bindSym bv,s) | bv <- bindNodes bv, s <- bindSyms bv] ++[(s,s') | v <- maybeToList v , ref <- S.toList $ references i v , s <- S.toList $ clobbers i ref@@ -117,9 +119,9 @@ argRefs i vs = S.toList $ S.fromList [s | SymVal Address s <- vs] <> S.unions [references i s | SymVal Value s <- vs] references i v = lookupRefs v (referencesA!i)- referencesA = treeArray next $ insertManyR R.empty [(worldID,s) | arg <- args, s <- bindSyms arg]+ referencesA = treeArray next $ insertManyR R.empty [(s,worldID) | arg <- args, s <- bindSyms arg] where next i r (Op _ v vs) = insertManyR r' (map (v,) $ argRefs i vs)- where r' = S.delete v (R.dom r) R.<| r+ where r' = foldr (uncurry R.delete) r [(v,v') | v' <- maybe [] S.toList $ R.lookupRan v r] next _ r _ = r constA bs v = accumArray const v bs []
src/Specialize/Architecture.hs view
@@ -16,7 +16,7 @@ undef s = error $ "undefined ("++s++")" -architectures = [hostArch,arch_x86,arch_x86_64,arch_arm]+architectures = [hostArch,arch_x86_64] nullArch = Arch undefined undefined (undef "initials") (undef "compile") arch_x86 = nullArch { archName = "x86", archDefaultSize = 4 } arch_arm = nullArch { archName = "arm", archDefaultSize = 4 }
src/Specialize/X86_64.hs view
@@ -292,16 +292,16 @@ storeGroup g = do ch <- lift $ gets (flip S.member . changed) let loaded = [(ch s,ge) | ge@(_,s,_) <- g]- reg <- if any fst loaded then loadRoot $ parent $ head g else return undefined- lift $ mapM_ (\(c,ge@(r,s,_)) -> when c (store reg ge)- >> associate r Nothing- >> modifyF changedF (S.delete s)) loaded- where store base (r,s,b) = do+ root <- if any fst loaded then loadRoot $ parent $ head g else return undefined+ lift $ mapM_ (\(c,ge@(r,s,_)) -> when c (store root ge >> modifyF changedF (S.delete s))) loaded+ where store root (r,s,b) = do n <- maybe (stackAddr (varSize s) s) (return . snd) b- st (base,fi n,fi (varSize s)) r+ st (root,fi n,fi (varSize s)) r restrict m = gets (SB.partition isFree) >>= \(free',occ) -> put free' >> m >> modify (SB.union occ) where isFree = isNothing . lookupSymIn regs+ restrict $ mapM_ storeGroup groups+ lift $ mapM_ (\(r,_,_) -> associate r Nothing) vars loadArgs args = do let modFRegs regs = foldr ($) regs [maybe (BM.deleteR r) (flip BM.insert r) $ argValSym arg