Changeset 2396

Show
Ignore:
Timestamp:
04/27/05 15:02:41 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
3914
Message:

* compiler repaired.

Location:
src
Files:
13 modified

Legend:

Unmodified
Added
Removed

  • src/Main.hs

    r2358 r2396  
    8989 
    9090dump :: String -> IO () 
    91 dump = (doParseWith $ \exp _ -> print exp) "-" 
    92  
    93 comp :: String -> IO () 
    94 comp = (doParseWith $ \exp _ -> putStrLn =<< compile "Haskell" exp) "-" 
     91dump = (doParseWith $ \env _ -> print $ envBody env) "-" 
     92 
     93dumpGlob :: String -> IO () 
     94dumpGlob = (doParseWith $ \env _ -> do 
     95    glob <- readIORef $ envGlobal env 
     96    print $ userDefined glob) "-" 
     97 
     98userDefined :: Pad -> Pad 
     99userDefined (MkPad pad) = MkPad $ Map.filterWithKey doFilter pad 
     100    where 
     101    doFilter (_:'*':_) _ = False 
     102    doFilter _ _         = True 
    95103 
    96104repLoop :: IO () 
    … …  
    117125 
    118126doExternal :: String -> FilePath -> String -> IO () 
    119 doExternal mod = doParseWith $ \exp _ -> do 
    120     str <- externalize mod exp 
     127doExternal mod = doParseWith $ \env _ -> do 
     128    str <- externalize mod $ envBody env 
    121129    putStrLn str 
    122130 
    123131doCompile :: [Char] -> FilePath -> String -> IO () 
    124 doCompile backend = doParseWith $ \exp _ -> do 
    125     str <- compile backend exp 
     132doCompile backend = doParseWith $ \env _ -> do 
     133    glob    <- readIORef $ envGlobal env 
     134    globRef <- newIORef $ userDefined glob 
     135    str  <- compile backend env{ envGlobal = globRef } 
    126136    writeFile "dump.ast" str 
    127137 
    128 doParseWith :: (Pugs.AST.Exp -> FilePath -> IO a) -> FilePath -> String -> IO a 
     138doParseWith :: (Env -> FilePath -> IO a) -> FilePath -> String -> IO a 
    129139doParseWith f name prog = do 
    130140    env <- emptyEnv [] 
    131     runRule env (f' . envBody) ruleProgram name $ decodeUTF8 prog 
    132     where 
    133     f' (Val err@(VError _ _)) = do 
     141    runRule env f' ruleProgram name $ decodeUTF8 prog 
     142    where 
     143    f' Env{ envBody = Val err@(VError _ _) } = do 
    134144        hPutStrLn stderr $ pretty err 
    135145        exitFailure 
    136     f' exp = f exp name 
     146    f' env = f env name 
    137147 
    138148 

  • src/Pugs/AST.hs

    r2390 r2396  
    508508    , subName = "&?" 
    509509    , subType = SubPrim 
    510     , subPad = Map.empty 
     510    , subPad = mkPad [] 
    511511    , subAssoc = "pre" 
    512512    , subParams = [] 
    … …  
    521521    , subName = "&?" 
    522522    , subType = SubBlock 
    523     , subPad = Map.empty 
     523    , subPad = mkPad [] 
    524524    , subAssoc = "pre" 
    525525    , subParams = [] 
    … …  
    677677    where 
    678678    showCxt CxtVoid         = "Void" 
    679     showCxt (CxtItem typ)   = "Scalar (" ++ show typ ++ ")" 
    680     showCxt (CxtSlurpy typ) = "List (" ++ show typ ++ ")" 
    681  
    682 type Pad = Map Var [IORef VRef] 
     679    showCxt (CxtItem typ)   = "Scalar (" ++ showType typ ++ ")" 
     680    showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")" 
     681 
     682newtype Pad = MkPad (Map Var [IORef VRef]) 
     683    deriving (Eq, Ord, Typeable) 
     684 
     685instance Show Pad where 
     686    show pad = "(mkPad [" ++  
     687                concat (intersperse ", " $ map dump $ padToList pad) ++ 
     688                "])" 
     689        where 
     690        dump (n, ioRefs) = "(" ++ show n ++ ", [" ++ 
     691                            concat (intersperse ", " $ map dumpIORef ioRefs) ++ 
     692                            "])" 
     693        dumpIORef ioRef = unsafePerformIO $ do 
     694            ref  <- readIORef ioRef 
     695            dump <- (`runReaderT` undefined) $ (`runContT` return) $ resetT $ do 
     696                dumpRef ref 
     697            return $ "unsafePerformIO (newIORef " ++ vCast dump ++ ")" 
     698 
     699mkPad = MkPad . Map.fromList 
     700lookupPad key (MkPad map) = Map.lookup key map 
     701padToList (MkPad map) = Map.assocs map 
     702diffPads (MkPad map1) (MkPad map2) = MkPad $ Map.difference map1 map2 
     703unionPads (MkPad map1) (MkPad map2) = MkPad $ Map.union map1 map2 
    683704 
    684705genMultiSym name ref = liftIO $ do 
    685706    ioRef <- newIORef ref 
    686     return $ Map.insertWith (++) name [ioRef] 
     707    return $ \(MkPad map) -> MkPad $ Map.insertWith (++) name [ioRef] map 
    687708 
    688709genSym name ref = liftIO $ do 
    689710    ioRef <- newIORef ref 
    690     return $ Map.insert name [ioRef] 
     711    return $ \(MkPad map) -> MkPad $ Map.insert name [ioRef] map 
    691712 
    692713show' :: (Show a) => a -> String 
    … …  
    705726 
    706727findSym :: String -> Pad -> Maybe (IORef VRef) 
    707 findSym name pad = case Map.lookup name pad of 
     728findSym name pad = case lookupPad name pad of 
    708729    Just (x:_)  -> Just x 
    709730    _           -> Nothing 
    … …  
    864885forceRef r = retError "cannot forceRef" (Val $ VRef r) 
    865886 
     887dumpRef :: VRef -> Eval Val 
     888dumpRef (MkRef (ICode cv)) = do 
     889    vsub <- Code.assuming cv [] [] 
     890    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
     891dumpRef (MkRef (IScalar sv)) | Scalar.iType sv == mkType "Scalar::Const" = do 
     892    sv <- Scalar.fetch sv 
     893    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
     894dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ show (refType ref) ++ "\")") 
     895 
    866896readRef :: VRef -> Eval Val 
    867897readRef (MkRef (IScalar sv)) = Scalar.fetch sv 
    … …  
    905935clearRef r = retError "cannot clearRef" (Val $ VRef r) 
    906936 
    907 newObject :: Type -> Eval VRef 
     937newObject :: (MonadIO m) => Type -> m VRef 
    908938newObject (MkType "Scalar") = liftIO $ 
    909939    return . scalarRef =<< newIORef undef 
    … …  
    914944newObject (MkType "Code")   = liftIO $ 
    915945    return . codeRef =<< newIORef mkSub 
    916 newObject typ      = do 
    917     retError ("Cannot create object" ++ (show typ)) (Val undef) 
     946newObject typ = fail ("Cannot create object: " ++ showType typ) 
    918947 
    919948-- XXX: Refactor doHash and doArray into one -- also see Eval's [] and {} 

  • src/Pugs/AST.hs-boot

    r2370 r2396  
    2525type VBlock = Exp 
    2626type Params = [Param] 
    27 type Pad = Map Var [IORef VRef] 
    2827 
    2928data Env 
    … …  
    3635 
    3736newtype VThunk = MkThunk (Eval Val) 
     37newtype Pad = MkPad (Map Var [IORef VRef]) 
    3838 
    3939data Exp 

  • src/Pugs/Compile.hs

    r2009 r2396  
    1111 
    1212module Pugs.Compile where 
     13import Pugs.AST 
    1314import Pugs.Compile.Pugs (genPugs) 
    1415import Pugs.Compile.Parrot (genPIR) 
    1516import Pugs.Compile.Haskell (genGHC) 
    1617 
     18compile :: String -> Env -> IO String 
    1719compile "Haskell" = genGHC 
    1820compile "Pugs" = genPugs 

  • src/Pugs/Compile/Haskell.hs

    r2319 r2396  
    1010 
    1111import Pugs.Internals 
    12 import Language.Haskell.TH as TH 
     12import qualified Language.Haskell.TH as TH 
    1313import Pugs.AST 
    1414import Pugs.Run 
    1515import Pugs.Prim 
    1616 
    17 genGHC exp = runQ [d| mainCC = runComp $(compile exp) |] >>= \str -> return . unlines $ 
    18     [ "{-# OPTIONS_GHC -fglasgow-exts -fth -O #-}" 
    19     , "module MainCC where" 
    20     , "import GHC.Base" 
    21     , "import Run" 
    22     , "import AST" 
    23     , "import Prim" 
    24     , "import Internals" 
    25     , "import Language.Haskell.TH as TH" 
    26     , "" 
    27     , pprint str 
    28     ] 
     17genGHC :: Env -> IO String 
     18genGHC Env{ envBody = exp } = 
     19    TH.runQ [d| mainCC = runComp $(compile exp) |] >>= \str -> return . unlines $ 
     20        [ "{-# OPTIONS_GHC -fglasgow-exts -fth -O #-}" 
     21        , "module MainCC where" 
     22        , "import GHC.Base" 
     23        , "import Run" 
     24        , "import AST" 
     25        , "import Pugs.Types" 
     26        , "import Prim" 
     27        , "import Internals" 
     28        , "import Language.Haskell.TH as TH" 
     29        , "" 
     30        , TH.pprint str 
     31        ] 
    2932 
    3033compile (App op [inv] []) = compile (App op [] [inv]) 

  • src/Pugs/Compile/Parrot.hs

    r2371 r2396  
    77import Data.HashTable 
    88import Text.PrettyPrint 
    9 import qualified Data.Map as Map 
    109 
    1110-- XXX This compiler needs a totaly rewrite using Parrot AST, 
    1211-- XXX and maybe TH-based AST combinators 
    1312 
    14 genPIR :: (Pugs.Compile.Parrot.Compile x, Monad m) => x -> m String 
    15 genPIR exp = return . unlines $ 
     13genPIR :: Env -> IO String 
     14genPIR Env{ envBody = exp } = return . unlines $ 
    1615    [ "#!/usr/bin/env parrot" 
    1716    , ".sub main @MAIN" 
    … …  
    118117          , varText name <+> text "=" <+> text "new" <+> varInit name 
    119118          ] 
    120           | name <- Map.keys pad 
     119          | (name, _) <- padToList pad 
    121120        ] 
    122121    compile (Syn "mval" [exp]) = compile exp 

  • src/Pugs/Compile/Pugs.hs

    r2078 r2396  
    22 
    33module Pugs.Compile.Pugs where 
     4import Pugs.AST 
    45import Pugs.Internals 
    56 
    6 genPugs :: (Show a, Monad m) => a -> m String 
    7 genPugs exp = return . unlines $ 
    8     [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds -O #-}" 
    9     , "module MainCC where" 
    10     , "import Pugs.Run" 
    11     , "import Pugs.AST" 
    12     , "import Pugs.Internals" 
    13     , "" 
    14     , "mainCC = runAST $ " ++ show exp 
    15     ] 
     7genPugs :: Env -> IO String 
     8genPugs Env{ envBody = exp, envGlobal = globRef } = do 
     9    glob <- readIORef globRef 
     10    return . unlines $ 
     11        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds -O #-}" 
     12        , "module MainCC where" 
     13        , "import Pugs.Run" 
     14        , "import Pugs.AST" 
     15        , "import Pugs.Types" 
     16        , "import Pugs.Internals" 
     17        , "" 
     18        , "mainCC = runAST glob ast" 
     19        , "    where" 
     20        , "    glob = " ++ show glob 
     21        , "    ast  = " ++ show exp 
     22        , "" 
     23        ] 
    1624 

  • src/Pugs/Eval.hs

    r2370 r2396  
    3535    uniq <- liftIO $ newUnique 
    3636    syms <- liftIO $ initSyms 
    37     glob <- liftIO $ newIORef (combine (pad ++ syms) Map.empty) 
     37    glob <- liftIO $ newIORef (combine (pad ++ syms) $ mkPad []) 
    3838    return $ Env 
    3939        { envContext = CxtVoid 
    40         , envLexical = Map.empty 
     40        , envLexical = mkPad [] 
    4141        , envLValue  = False 
    4242        , envGlobal  = glob 
    … …  
    9595    syms <- forM [lex, glob] $ \pad -> do 
    9696        forM names $ \name' -> do 
    97             case Map.lookup name' pad of 
     97            case lookupPad name' pad of 
    9898                Just ioRefs -> do 
    9999                    refs  <- liftIO $ mapM readIORef ioRefs 
    … …  
    147147        let doRest = reduceStatements rest e 
    148148        lex <- asks envLexical 
    149         local (\e -> e{ envLexical = lex' `Map.union` lex }) doRest 
     149        local (\e -> e{ envLexical = lex' `unionPads` lex }) doRest 
    150150    Syn "env" [] | null rest -> const $ do 
    151151        env <- ask 
    … …  
    153153    Syn "dump" [] | null rest -> \e -> do 
    154154        Env{ envGlobal = globals, envLexical = lexicals } <- ask 
    155         liftIO $ modifyIORef globals (Map.union lexicals) 
     155        liftIO $ modifyIORef globals (unionPads lexicals) 
    156156        reduceStatements rest e 
    157157    _ | null rest -> const $ do 

  • src/Pugs/Monads.hs

    r2390 r2396  
    1515import Pugs.Context 
    1616import Pugs.Types 
    17 import qualified Data.Map as Map 
    1817 
    1918headVal []    = retEmpty 
    … …  
    8988        | typ >= SubBlock = do 
    9089            blockRec <- genSym "&?BLOCK" (codeRef (orig sub)) 
    91             return $ \e -> e{ envLexical = combine [blockRec] (subPad sub `Map.union` pad) } 
     90            return $ \e -> e 
     91                { envLexical = combine [blockRec] (subPad sub `unionPads` pad) } 
    9292        | otherwise = do 
    9393            subRec <- sequence 

  • src/Pugs/Parser.hs

    r2370 r2396  
    2222import Pugs.Rule.Error 
    2323import Pugs.Pretty 
    24 import qualified Data.Map as Map 
    2524 
    2625-- Lexical units -------------------------------------------------- 
    … …  
    3130    eof 
    3231    env <- getState 
    33     return $ env { envBody = statements } 
     32    return $ env { envBody = statements, envStash = "" } 
    3433 
    3534ruleBlock :: RuleParser Exp 
    … …  
    232231            , subFun        = fun 
    233232            } 
    234         exp = Stmts 
    235             [ (Sym scope name, namePos) 
    236             , (Syn ":=" [Var name, Syn "sub" [subExp]], bodyPos) 
    237             ] 
     233        decl = (Sym scope name, namePos) 
     234        exp  = (Syn ":=" [Var name, Syn "sub" [subExp]], bodyPos) 
    238235    -- XXX: user-defined infix operator 
    239236    if scope == SGlobal 
    240         then do { unsafeEvalExp exp; return emptyExp } 
    241         else return exp 
     237        then do { unsafeEvalExp (Stmts [decl, exp]); return emptyExp } 
     238        else do 
     239            lexDiff <- unsafeEvalLexDiff [decl] 
     240            let lexExp = (Pad scope lexDiff, namePos) 
     241            return $ Stmts [lexExp, exp] 
    242242 
    243243subNameWithPrefix prefix = (<?> "subroutine name") $ lexeme $ try $ do 
    … …  
    317317        exp <- ruleExpression 
    318318        return (sym, Just exp) 
    319     env  <- getState 
    320     env' <- unsafeEvalStmts decl 
    321     setState env' 
     319    lexDiff <- unsafeEvalLexDiff decl 
    322320    let lexExp  = (Pad scope lexDiff, pos) 
    323         lexDiff = envLexical env' `Map.difference` envLexical env 
    324321    return $ case expMaybe of 
    325322        Just exp -> Stmts [lexExp, (Syn sym [lhs, exp], pos)] 
    … …  
    393390        _       -> fail "" 
    394391 
     392unsafeEvalLexDiff decl = do 
     393    env  <- getState 
     394    env' <- unsafeEvalStmts decl 
     395    setState env' 
     396    return $ envLexical env' `diffPads` envLexical env 
     397 
    395398unsafeEvalStmts stmts = do 
    396399    pos <- getPosition 
     400    env <- getState 
    397401    val <- unsafeEvalExp $ Stmts (stmts ++ [(Syn "env" [], pos)]) 
    398402    case val of 
    399         Val (VControl (ControlEnv env)) -> return env 
    400         _                               -> error $ pretty val 
     403        Val (VControl (ControlEnv env')) -> 
     404            return env'{ envDebug = envDebug env } 
     405        _  -> error $ pretty val 
    401406 
    402407unsafeEvalExp exp = do 
    … …  
    547552            { isMulti       = False 
    548553            , subName       = "<anon>" 
    549             , subPad        = Map.empty 
     554            , subPad        = mkPad [] 
    550555            , subType       = typ 
    551556            , subAssoc      = "pre" 
    … …  
    650655    return . concat . unsafePerformIO $ do 
    651656        glob <- readIORef $ envGlobal env 
    652         forM (Map.assocs glob ++ Map.assocs (envLexical env)) $ \(name, ioRefs) -> do 
     657        forM (padToList glob ++ padToList (envLexical env)) $ \(name, ioRefs) -> do 
    653658            refs <- mapM readIORef ioRefs 
    654659            return $ map (\ref -> (dropWhile isPunctuation $ name, ref)) refs 

  • src/Pugs/Pretty.hs

    r2377 r2396  
    1818import Text.PrettyPrint 
    1919import qualified Data.Set as Set 
    20 import qualified Data.Map as Map 
    2120 
    2221defaultIndent :: Int 
    … …  
    4039 
    4140instance Pretty Pad where 
    42     format pad = cat $ map formatAssoc (Map.assocs pad) 
     41    format pad = cat $ map formatAssoc $ padToList pad 
    4342        where 
    4443        formatAssoc (name, var) = format name <+> text ":=" <+> (nest defaultIndent $ vcat $ map format var) 

  • src/Pugs/Run.hs

    r2358 r2396  
    3636runEnv env = runEval env $ evaluateMain (envBody env) 
    3737 
    38 runAST :: Exp -> IO Val 
    39 runAST ast = do 
     38runAST :: Pad -> Exp -> IO Val 
     39runAST glob ast = do 
    4040    hSetBuffering stdout NoBuffering 
    41     name <- getProgName 
    42     args <- getArgs 
    43     env  <- prepareEnv name args 
    44     runEnv env{ envBody = ast, envDebug = Nothing } 
     41    name    <- getProgName 
     42    args    <- getArgs 
     43    env     <- prepareEnv name args 
     44    glob'   <- readIORef $ envGlobal env 
     45    globRef <- newIORef (glob `unionPads` glob') 
     46    runEnv env{ envBody = ast, envGlobal = globRef, envDebug = Nothing } 
    4547 
    4648runComp :: Eval Val -> IO Val 

  • src/Pugs/Types.hs

    r2362 r2396  
    2121 
    2222instance Show Type where 
    23     show (MkType typ)    = typ 
    24     show (TypeOr t1 t2)  = show t1 ++ "|" ++ show t2 
    25     show (TypeAnd t1 t2) = show t1 ++ "&" ++ show t2 
     23    show t = "(mkType \"" ++ showType t ++ "\")" 
     24 
     25showType (MkType typ)    = typ 
     26showType (TypeOr t1 t2)  = showType t1 ++ "|" ++ showType t2 
     27showType (TypeAnd t1 t2) = showType t1 ++ "&" ++ showType t2 
    2628 
    2729type ClassTree = Tree Type