Changeset 7843 for src/Pugs/Compile/Pugs.hs

Timestamp:

11/05/05 11:41:57 (3 years ago)

Author:

autrijus

Message:

[Massive backport from svn.perl.org now openfoundry is back]

* theorbtwo notes that FIRST {} blocks did not

desugar into anything that passes PIL compilation,
as it's useing a Stmt in LValue position.
Fixed by desugaring using ternary if.

* Squash an empty import warning for precompiled preludes.

* Support for "./pugs -C PIL2".

Currently, "-C PIL" and "-C PIL1" both maps to PIL1,
but some day "-C PIL" may change to PIL2.

* Repo copy Pugs.CodeGen?.PIL to Pugs.CodeGen?.PIL2
* Also rename CodeGen?.PIL to CodeGen?.PIL1

* Add DrIFT-generated source of PIL2.hs.

* Repo copy PIL1 to PIL2 for the long-much-overdue PIL2

refactoring. The goals are:

• Compile time object serialization
• Lexical hoisting
• Static creation of Code objects with scope (no PSub forms)
• Full Cxt information
• PIL2 is *after* type erasure -- *no* static type annotation should be left after that -- it's somewhere between F<: and ANF, so to speak.

* Adds support for "./pugs -BPugs -e ...", which just takes

-CPugs output and feed to the "runghc" executable in PATH.

* pugscc: chase the s/MainCC.mainCC/Main.main/ change

as the now-cabalized Pugs package no longer exports "main".

* Compile-time objects now survives "./pugs -CPugs" compilation.

This means the line below works now:

pugscc -e 'class F {}; my $x ::= F.new; say $x'

Previously, the ::= would prevent compilation because we
did not have a serialization protocol for VObject types.
(This work is going to be carried over to PIL.)

Files:

• src/Pugs/Compile/Pugs.hs (modified) (7 diffs)

src/Pugs/Compile/Pugs.hs

@@ -1 @@
-{-# OPTIONS_GHC -cpp -fglasgow-exts -fth #-}
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
 
 #include "../pugs_config.h"
@@ -8 +8 @@
 import Pugs.Internals
 import Text.PrettyPrint
+import qualified Data.Map as Map
 
 class (Show x) => Compile x where
@@ -25 +26 @@
 
 prettyDo :: [Doc] -> Doc
-prettyDo docs = parens $ sep (text "do":punctuate semi docs)
+prettyDo docs = parens $ text "do" <+> braces (sep $ punctuate semi docs)
 
 prettyRecord :: String -> [(String, Doc)] -> Doc
@@ -32 +33 @@
 
 prettyBind :: String -> Doc -> Doc
-prettyBind var doc = text var `sep1` nest 1 (text "<-" <+> doc)
-
+prettyBind var doc = text var <+> text "<-" <+> doc
 
 instance Compile (Maybe Exp) where
@@ -127 +127 @@
                 ]
 
-instance Compile (TVar Bool) where
-    compile fresh = do
-        bool <- liftSTM $ readTVar fresh
-        return $ text "liftSTM" <+> parens (text "newTVar" <+> text (show bool))
-
-instance Compile (TVar VRef) where
+instance Compile Bool where
+    compile bool = return $ text "return" <+> parens (text $ show bool)
+
+instance Compile a => Compile (Map VStr a) where
+    compile map | Map.null map = return (text "return Map.empty")
+    compile map = error (show map) 
+
+instance Compile (IVar VScalar) where
+    compile iv = do
+        val     <- readIVar iv
+        valC    <- compile val
+        return $ prettyDo
+            [ prettyBind "val" valC
+            , text "newScalar val"
+            ]
+
+instance (Typeable a, Compile a) => Compile (TVar a) where
     compile fresh = do
         vref    <- liftSTM $ readTVar fresh
@@ -169 +180 @@
             , text "return $ VCode code"
             ]
+    compile (VObject obj) = do
+        objC <- compile obj
+        return $ prettyDo
+            [ prettyBind "obj" objC
+            , text "return $ VObject obj"
+            ]
     compile x = return $ text "return" $+$ parens (text $ show x)
 
--- We need a compile VObject!
+instance Compile VObject where
+    compile (MkObject typ attrs Nothing _) = do
+        attrsC <- compile attrs
+        let vobj = prettyRecord "MkObject" $
+                [ ("objType",   text (show typ))
+                , ("objAttrs",  text "attrs")
+                , ("objOpaque", text "Nothing")
+                , ("objId",     text "id")
+                ]
+        return $ prettyDo
+            [ prettyBind "attrs" attrsC
+            , prettyBind "id" (text "liftIO newUnique")
+            , text "return" <+> parens vobj
+            ]
+    compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj
 
 -- Haddock can't cope with Template Haskell
@@ -207 +238 @@
     expC    <- compile exp
     return . VStr . unlines $
-        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds -O #-}"
-        , "module MainCC where"
+        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds #-}"
+        , "module Main where"
         , "import Pugs.Run"
         , "import Pugs.AST"
         , "import Pugs.Types"
         , "import Pugs.Internals"
-        , ""
-        , "mainCC = do"
+        , "import qualified Data.Map as Map"
+        , ""
+        , "main = do"
         , "    glob <- globC"
         , "    exp  <- expC"