Changeset 2401

Timestamp:

04/27/05 17:17:20 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

3914

Message:

* compile subroutines to Parrot.

Location:

src/Pugs

Files:

• AST.hs (modified) (1 diff)
• Compile.hs (modified) (2 diffs)
• Compile/Haskell.hs (modified) (1 diff)
• Compile/Parrot.hs (modified) (6 diffs)
• Compile/Pugs.hs (modified) (1 diff)
• Run.hs (modified) (1 diff)

src/Pugs/AST.hs

@@ -718 +718 @@
 
 type Eval x = ContT Val (ReaderT Env IO) x
+
+runEval :: Env -> Eval Val -> IO Val
+runEval env eval = withSocketsDo $ do
+    my_perl <- initPerl5 ""
+    val <- (`runReaderT` env) $ do
+        (`runContT` return) $
+            resetT eval
+    freePerl5 my_perl
+    return val
 
 findSymRef :: (MonadIO m) => String -> Pad -> m VRef

src/Pugs/Compile.hs

@@ -12 +12 @@
 module Pugs.Compile where
 import Pugs.AST
+import Pugs.Internals
 import Pugs.Compile.Pugs (genPugs)
 import Pugs.Compile.Parrot (genPIR)
@@ -17 +18 @@
 
 compile :: String -> Env -> IO String
-compile "Haskell" = genGHC
-compile "Pugs" = genPugs
-compile "Parrot" = genPIR
-compile s = const (error $ "Cannot compile to " ++ s)
+compile "Haskell" env = fmap vCast $ runEval env genGHC
+compile "Pugs"    env = fmap vCast $ runEval env genPugs
+compile "Parrot"  env = fmap vCast $ runEval env genPIR
+compile s _ = fail $ "Cannot compile to " ++ s
 

src/Pugs/Compile/Haskell.hs

@@ -15 +15 @@
 import Pugs.Prim
 
-genGHC :: Env -> IO String
-genGHC Env{ envBody = exp } =
-    TH.runQ [d| mainCC = runComp $(compile exp) |] >>= \str -> return . unlines $
+genGHC :: Eval Val
+genGHC = do
+    exp <- asks envBody
+    liftIO (TH.runQ [d| mainCC = runComp $(compile exp) |]) >>= \str -> return . VStr . unlines $
         [ "{-# OPTIONS_GHC -fglasgow-exts -fth -O #-}"
         , "module MainCC where"

src/Pugs/Compile/Parrot.hs

@@ -5 +5 @@
 import Pugs.Pretty
 import Pugs.AST
+import Pugs.Types
 import Data.HashTable
 import Text.PrettyPrint
+import qualified Pugs.Types.Scalar as Scalar
+import qualified Pugs.Types.Code   as Code
 
 -- XXX This compiler needs a totaly rewrite using Parrot AST,
 -- XXX and maybe TH-based AST combinators
 
-genPIR :: Env -> IO String
-genPIR Env{ envBody = exp } = return . unlines $
-    [ "#!/usr/bin/env parrot"
-    , ".sub main @MAIN"
-    , ""
-    , renderStyle (Style LeftMode 0 0) (compile exp)
-    , ".end"
-    ]
+genPIR :: Eval Val
+genPIR = do
+    Env{ envBody = exp, envGlobal = globRef } <- ask
+
+    glob <- liftIO $ readIORef globRef
+
+    -- get a list of functions
+    init <- compileEval glob
+
+    return . VStr . unlines $
+        [ "#!/usr/bin/env parrot"
+        , renderStyle (Style PageMode 0 0) init
+        , renderStyle (Style PageMode 0 0) $ vcat
+            [ text ".sub main @MAIN"
+            , nest 4 (compile exp)
+            , text ".end"
+            ]
+        ]
+
+instance Compile Doc where
+    compile = id
+
+instance Compile Pad where
+    compileEval pad = fmap vcat $ mapM compileEval (padToList pad)
+
+instance Compile (String, [IORef VRef]) where
+    compileEval (('&':name), [sym]) = do
+        imc <- compileEval sym
+        return $ vcat
+            [ text (".sub \"" ++ name ++ "\"")
+            , nest 4 imc
+            , text ".end"
+            ]
+    compileEval x = internalError ("Unrecognized construct: " ++ show x)
+
+instance Compile (IORef VRef) where
+    compileEval x = do
+        ref <- liftIO $ readIORef x
+        compileEval ref
+
+instance Compile VRef where
+    compileEval (MkRef (ICode cv)) = do
+        vsub <- Code.fetch cv
+        compileEval vsub
+    compileEval (MkRef (IScalar sv))
+        | Scalar.iType sv == mkType "Scalar::Const" = do
+            sv  <- Scalar.fetch sv
+            ref <- fromVal sv
+            compileEval (ref :: VCode)
+    compileEval x = internalError ("Unrecognized construct: " ++ show x)
+
+instance Compile VCode where
+    compileEval sub = do
+        prms <- mapM compileEval (subParams sub)
+        body <- compileEval (subFun sub)
+        return . vcat $ prms ++ [ text "", body ]
+
+instance Compile Param where
+    compile prm = text ".param pmc" <+> varText (paramName prm)
 
 class (Show x) => Compile x where
+    compileEval :: x -> Eval Doc
+    compileEval x = return (compile x)
     compile :: x -> Doc
     compile x = internalError ("Unrecognized construct: " ++ show x)
@@ -61 +117 @@
     compile (Var name) = varText name
     compile (Syn ";" stmts) = vcat $ map compile stmts
-    compile (Syn "=" [var, Syn "[]" [lhs, rhs]]) = vcat $
-        [ compile var <+> text "=" <+> compile lhs <> text "[" <> compile rhs <> text"]"
-        ]
     compile (Syn "block" blocks) = vcat $ map compile blocks
-    compile (Syn "=" [lhs, rhs@(Var _)]) = hsep $
-        [ compile lhs, text "=", text "assign", compile rhs ]
-    compile (Syn "=" [lhs, rhs]) = hsep $
-        [ compile lhs, text "=", compile rhs ]
+    compile (Syn "=" [lhs, rhs]) = compileAssign lhs rhs
     compile (Syn "if" exps) = compileCond "unless" exps
     compile (Syn "unless" exps) = compileCond "if" exps
@@ -87 +137 @@
             , label last
             ]
+    compile (App "&return" [] [val]) = text ".return" <+> parens (compile val)
     compile (App "&last" _ _) = text "invoke last"
     compile (App "&substr" [] [str, start, Val (VInt 1)]) = hcat $
@@ -102 +153 @@
         compile $ App "&print" invs (args ++ [Val $ VStr "\n"])
     compile (App "&print" invs args) = vcat $
-        map ((text "print" <+>) . compile) (invs ++ args)
+        map (\x -> vcat
+                [ text ".local pmc tmp"
+                , text "tmp = new PerlUndef"
+                , compileAssign (text "tmp") x
+                , text "print tmp"
+                ])
+            (invs ++ args)
+    compile (App "&not" [] []) =
+        text "new" <+> compile (Val VUndef)
     compile (Val (VStr x))  = showText $ encodeUTF8 (concatMap quoted x)
     compile (Val (VInt x))  = integer x
@@ -121 +180 @@
     compile (Syn "mval" [exp]) = compile exp
     compile (Syn "," things) = vcat $ map compile things
-    compile (App "&not" [] []) =
-        text "new" <+> compile (Val VUndef)
+    compile (Syn syn [lhs, exp]) | last syn == '=' =
+        compile $ Syn "=" [lhs, App ("&infix:" ++ init syn) [lhs, exp] []]
     compile (Cxt _ exp) = compile exp
     compile x = error $ "Cannot compile: " ++ (show x)
@@ -129 +188 @@
 showText = text . show
 
+compileAssign :: (Compile a) => a -> Exp -> Doc
+compileAssign lhs rhs@(Var _) = hsep [ compile lhs, text "=", text "assign", compile rhs ]
+compileAssign lhs (App ('&':name) _ [arg]) = vcat $
+        [ text ".local pmc tmp"
+        , text "tmp = new PerlUndef"
+        , compileAssign (text "tmp") arg
+        , hsep [compile lhs, text "=", text name <> parens (text "tmp")]
+        ]
+compileAssign lhs (Syn "[]" [arr, idx]) = vcat $
+        [ compile lhs <+> text "=" <+> compile arr <> text "[" <> compile idx <> text"]"
+        ]
+compileAssign lhs rhs = hsep [ compile lhs, text "=", compile rhs ]

src/Pugs/Compile/Pugs.hs

@@ -5 +5 @@
 import Pugs.Internals
 
-genPugs :: Env -> IO String
-genPugs Env{ envBody = exp, envGlobal = globRef } = do
-    glob <- readIORef globRef
-    return . unlines $
+genPugs :: Eval Val
+genPugs = do
+    Env{ envBody = exp, envGlobal = globRef } <- ask
+    glob <- liftIO $ readIORef globRef
+    return . VStr . unlines $
         [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds -O #-}"
         , "module MainCC where"

src/Pugs/Run.hs

@@ -23 +23 @@
     args <- getArgs
     f $ canonicalArgs args
-
-runEval :: Env -> Eval Val -> IO Val
-runEval env eval = withSocketsDo $ do
-    my_perl <- initPerl5 ""
-    val <- (`runReaderT` env) $ do
-        (`runContT` return) $
-            resetT eval
-    freePerl5 my_perl
-    return val
 
 runEnv :: Env -> IO Val