Changeset 7843 for src/Pugs/Compile

Show
Ignore:
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:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Compile/Pugs.hs

    r5360 r7843  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fth #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts #-} 
    22 
    33#include "../pugs_config.h" 
    … …  
    88import Pugs.Internals 
    99import Text.PrettyPrint 
     10import qualified Data.Map as Map 
    1011 
    1112class (Show x) => Compile x where 
    … …  
    2526 
    2627prettyDo :: [Doc] -> Doc 
    27 prettyDo docs = parens $ sep (text "do":punctuate semi docs) 
     28prettyDo docs = parens $ text "do" <+> braces (sep $ punctuate semi docs) 
    2829 
    2930prettyRecord :: String -> [(String, Doc)] -> Doc 
    … …  
    3233 
    3334prettyBind :: String -> Doc -> Doc 
    34 prettyBind var doc = text var `sep1` nest 1 (text "<-" <+> doc) 
    35  
     35prettyBind var doc = text var <+> text "<-" <+> doc 
    3636 
    3737instance Compile (Maybe Exp) where 
    … …  
    127127                ] 
    128128 
    129 instance Compile (TVar Bool) where 
    130     compile fresh = do 
    131         bool <- liftSTM $ readTVar fresh 
    132         return $ text "liftSTM" <+> parens (text "newTVar" <+> text (show bool)) 
    133  
    134 instance Compile (TVar VRef) where 
     129instance Compile Bool where 
     130    compile bool = return $ text "return" <+> parens (text $ show bool) 
     131 
     132instance Compile a => Compile (Map VStr a) where 
     133    compile map | Map.null map = return (text "return Map.empty") 
     134    compile map = error (show map)  
     135 
     136instance Compile (IVar VScalar) where 
     137    compile iv = do 
     138        val     <- readIVar iv 
     139        valC    <- compile val 
     140        return $ prettyDo 
     141            [ prettyBind "val" valC 
     142            , text "newScalar val" 
     143            ] 
     144 
     145instance (Typeable a, Compile a) => Compile (TVar a) where 
    135146    compile fresh = do 
    136147        vref    <- liftSTM $ readTVar fresh 
    … …  
    169180            , text "return $ VCode code" 
    170181            ] 
     182    compile (VObject obj) = do 
     183        objC <- compile obj 
     184        return $ prettyDo 
     185            [ prettyBind "obj" objC 
     186            , text "return $ VObject obj" 
     187            ] 
    171188    compile x = return $ text "return" $+$ parens (text $ show x) 
    172189 
    173 -- We need a compile VObject! 
     190instance Compile VObject where 
     191    compile (MkObject typ attrs Nothing _) = do 
     192        attrsC <- compile attrs 
     193        let vobj = prettyRecord "MkObject" $ 
     194                [ ("objType",   text (show typ)) 
     195                , ("objAttrs",  text "attrs") 
     196                , ("objOpaque", text "Nothing") 
     197                , ("objId",     text "id") 
     198                ] 
     199        return $ prettyDo 
     200            [ prettyBind "attrs" attrsC 
     201            , prettyBind "id" (text "liftIO newUnique") 
     202            , text "return" <+> parens vobj 
     203            ] 
     204    compile obj = fail $ "Cannot compile Object of Dynamic type: " ++ show obj 
    174205 
    175206-- Haddock can't cope with Template Haskell 
    … …  
    207238    expC    <- compile exp 
    208239    return . VStr . unlines $ 
    209         [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds -O #-}" 
    210         , "module MainCC where" 
     240        [ "{-# OPTIONS_GHC -fglasgow-exts -fno-warn-unused-imports -fno-warn-unused-binds #-}" 
     241        , "module Main where" 
    211242        , "import Pugs.Run" 
    212243        , "import Pugs.AST" 
    213244        , "import Pugs.Types" 
    214245        , "import Pugs.Internals" 
    215         , "" 
    216         , "mainCC = do" 
     246        , "import qualified Data.Map as Map" 
     247        , "" 
     248        , "main = do" 
    217249        , "    glob <- globC" 
    218250        , "    exp  <- expC"