Changeset 4655 for src/Emit/PIR.hs

Timestamp:

06/14/05 23:42:15 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

6394

Message:

* PAST compileation and PIR emission, phase 1, works! Try this,

which generates, according to Leo, "100% correct" PIR:

% ./pugs -C PIR -e 'say "Hello, World!"'
% parrot dump.ast
Hello, World!

* Also because it's now a Proper Compiler, we have this now:

% ./pugs -C PIR -e '"Hello, World!"'
*** Literal value used in constant expression: VStr "Hello, World!"

Files:

• src/Emit/PIR.hs (modified) (5 diffs)

src/Emit/PIR.hs

@@ -1 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
 
 module Emit.PIR where
 import Text.PrettyPrint
+import Pugs.Internals
+import Pugs.Pretty
 
 data RegType = RegInt | RegNum | RegStr | RegPMC
@@ -16 +18 @@
 type SubName    = String
 type VarName    = String
+type PrimName   = String
+type PkgName    = String
 
 data Identifier
-    = Var VarName
-    | Reg RegType Int
+    = VAR VarName
+    | PMC Int
+    deriving (Show, Eq)
 
 data Literal
@@ -25 +30 @@
     | LitInt Integer
     | LitNum Double
+    deriving (Show, Eq)
 
 class (Show x) => Emit x where
-    emit :: (Monad m) => x -> m Doc
-    emit x = fail ("Unrecognized construct: " ++ show x)
+    emit :: x -> Doc
+    -- emit x = error ("Unrecognized construct: " ++ show x)
+
+instance Emit String where
+    emit = text
+
+instance Emit Decl where
+    emit (DeclNS name) = emit ".namespace" <+> brackets (quotes $ emit name)
+    emit (DeclSub name styps stmts)
+        =  (emit ".sub" <+> doubleQuotes (emit name) <+> commaSep styps)
+        $+$ nested stmts
+        $+$ emit ".end"
+
+instance Emit SubType where
+    emit = emit . ('@':) . drop 3 . show
+
+instance (Emit a) => Emit [a] where
+    emit = vcat . map emit
+
+nested :: (Emit x) => x -> Doc
+nested = nest 4 . emit
+
+eqSep :: (Emit a, Emit b, Emit c) => a -> b -> [c] -> Doc
+eqSep lhs rhs args = emit lhs <+> equals <+> emit rhs <+> commaSep args
+
+commaSep :: (Emit x) => [x] -> Doc
+commaSep = hsep . punctuate comma . map emit
+
+curPad :: Doc
+curPad = int (-1)
+
+instance Emit Stmt where
+    emit (StmtComment []) = empty
+    emit (StmtComment str) = char '#' <+> emit str
+    emit (StmtLine file line) = text "#line" <+> doubleQuotes (emit file) <+> emit line
+    emit (StmtIns ins) = emit ins
+    emit (StmtLabel name ins) = emit name <> colon $+$ emit ins
+    emit (StmtPad stmts) = emit "new_pad" <+> curPad
+
+instance Emit RegType where
+    emit = emit . map toLower . drop 3 . show
+
+instance Emit Ins where
+    emit (InsLocal rtyp name) = emit ".local" <+> emit rtyp <+> emit name
+    emit (InsNew ident otyp) = eqSep ident "new" [otyp]
+    emit (InsAssign ident lit) = eqSep ident lit noArgs
+    emit (InsFun rets name args) = vcat
+        [ eqSep (PMC 0) "find_name" [LitStr name]
+        , emit "set_args" <+> sig <> comma <+> commaSep args
+        , emit "invokecc" <+> emit (PMC 0)
+        ]
+        where
+        sig = quotes $ parens (commaSep (replicate (length args) "0"))
+    emit x = error $ "can't emit: " ++ show x
+
+noArgs :: [Identifier]
+noArgs = []
+
+-- set_args '(0b0,0b0,0b0)', $P1, $P2, $P3
+
+instance Emit ObjType where
+    emit = emit . ('.':) . show
+
+instance Emit Identifier where
+    emit (VAR name) = emit name
+    emit (PMC num) = emit "$P" <> emit num
+
+instance Emit Literal where
+    emit (LitStr str) = text . show $ encodeUTF8 (concatMap quoted str)
+
+instance Emit Int where
+    emit = int
 
 data Stmt
-    = Comment   String
-    | Ins       Instruction
-    | Label     LabelName Instruction
+    = StmtComment   String
+    | StmtLine      FilePath Int
+    | StmtIns       Ins
+    | StmtLabel     LabelName Ins
+    | StmtPad       [Stmt]
+    deriving (Show, Eq)
 
-data Instruction
-    = Local     RegType VarName
-    | New       ObjType Identifier
-    | Set       Identifier Literal
-    | Assign    Identifier Literal
+data Ins
+    = InsLocal      RegType VarName
+    | InsNew        Identifier ObjType 
+    | InsBind       Identifier Identifier
+    | InsAssign     Identifier Literal
+    | InsFun        [Identifier] PrimName [Identifier]
+    | InsPrim       (Maybe Identifier) PrimName [Identifier]
+    | InsStoreLex   VarName Identifier
+    deriving (Show, Eq)
 
-data SubType = SubMAIN | SubLOAD | SubANON | SubMETHOD
+data SubType = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI [ObjType]
     deriving (Show, Eq)
 
 type PIR = [Decl]
 
-data Decl = Sub SubName [SubType]
+data Decl
+    = DeclSub   SubName [SubType] [Stmt]
+    | DeclNS    PkgName
+    deriving (Show, Eq)
 
 {-
@@ -54 +140 @@
 .end
     Comment :: String -> PIR Stmt
-    Stmt    :: Maybe Label -> PIR Instruction -> PIR Stmt
+    Stmt    :: Maybe Label -> PIR Ins -> PIR Stmt
     RegHard :: RegType -> Int -> PIR Var
     RegTemp :: RegType -> Int -> PIR Var
@@ -74 +160 @@
     CondCmp :: Bool -> PIR Var -> RelOP -> PIR Var -> Ident -> PIR Stmt
 -}
+
+preludePIR :: Doc
+preludePIR = vcat . map emit $
+    [ ".sub \"&print\""
+    , "    get_params '(0b1000)', $P0"
+    , "    $S0 = join '', $P0"
+    , "    print $S0"
+    , ".end"
+    , ""
+    , ".sub \"&say\""
+    , "    get_params '(0b1000)', $P0"
+    , "    $P1 = find_name '&print'"
+    , "    set_args '(0b1000)', $P0"
+    , "    invokecc $P1"
+    , "    print \"\\n\""
+    , ".end"
+    , ""
+    , ".namespace ['main']"
+    , ""
+    ]