First pass at implementing info tables for CPS

[ghc-hetmet.git] / compiler / cmm / CmmParse.y

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 567dd60..ab50799 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -199,23 +199,24 @@ lits      :: { [ExtFCode CmmExpr] }
        | ',' expr lits         { $2 : $3 }
 
 cmmproc :: { ExtCode }
-       : info maybe_formals '{' body '}'
-               { do (info_lbl, info1, info2) <- $1;
-                    formals <- sequence $2;
-                    stmts <- getCgStmtsEC (loopDecls $4)
-                    blks <- code (cgStmtsToBlocks stmts)
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
-
-       | info maybe_formals ';'
-               { do (info_lbl, info1, info2) <- $1;
-                    formals <- sequence $2;
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
-
-       | NAME maybe_formals '{' body '}'
+-- TODO: add real SRT/info tables to parsed Cmm
+--     : info maybe_formals '{' body '}'
+--             { do (info_lbl, info1, info2) <- $1;
+--                  formals <- sequence $2;
+--                  stmts <- getCgStmtsEC (loopDecls $4)
+--                  blks <- code (cgStmtsToBlocks stmts)
+--                  code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
+--
+--     | info maybe_formals ';'
+--             { do (info_lbl, info1, info2) <- $1;
+--                  formals <- sequence $2;
+--                  code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
+
+       : NAME maybe_formals '{' body '}'
                { do formals <- sequence $2;
                     stmts <- getCgStmtsEC (loopDecls $4);
                     blks <- code (cgStmtsToBlocks stmts);
-                    code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
+                    code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
 
 info   :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
@@ -261,16 +262,21 @@ stmt      :: { ExtCode }
        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }
 
--- HACK: this should just be lregs but that causes a shift/reduce conflict
--- with foreign calls
---     | hint_lregs '=' expr ';'
---             { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
+       | lreg '=' expr ';'
+               { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
+
+       -- Gah! We really want to say "maybe_results" but that causes
+       -- a shift/reduce conflict with assignment.  We either
+       -- we expand out the no-result and single result cases or
+       -- we tweak the syntax to avoid the conflict.  The later
+       -- option is taken here because the other way would require
+       -- multiple levels of expanding and get unwieldy.
        | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-               {% foreignCall $3 $1 $4 $6 $8 }
+               {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
        | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-               {% primCall $1 $4 $6 $8 }
+               {% primCall $1 $4 $6 $8 NoC_SRT }
        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
        -- Perhaps we ought to use the %%-form?
        | NAME '(' exprs0 ')' ';'
@@ -406,15 +412,11 @@ reg       :: { ExtFCode CmmExpr }
 
 maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
        : {- empty -}           { [] }
-       | hint_lregs '='        { $1 }
-
-hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
-       : {- empty -}           { [] }
-       | hint_lregs            { $1 }
+       | '(' hint_lregs ')' '='        { $2 }
 
 hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
-       : hint_lreg ','                 { [$1] }
-       | hint_lreg                     { [$1] }
+       : hint_lreg                     { [$1] }
+       | hint_lreg ','                 { [$1] }
        | hint_lreg ',' hint_lregs      { $1 : $3 }
 
 hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
@@ -818,8 +820,10 @@ foreignCall
        -> [ExtFCode (CmmFormal,MachHint)]
        -> ExtFCode CmmExpr
        -> [ExtFCode (CmmExpr,MachHint)]
-       -> Maybe [GlobalReg] -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols
+       -> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+foreignCall conv_string results_code expr_code args_code vols srt
   = do  convention <- case conv_string of
           "C" -> return CCallConv
           "C--" -> return CmmCallConv
@@ -829,20 +833,22 @@ foreignCall conv_string results_code expr_code args_code vols
          expr <- expr_code
          args <- sequence args_code
           code (emitForeignCall' PlayRisky results 
-                 (CmmForeignCall expr convention) args vols) where
+                 (CmmForeignCall expr convention) args vols srt) where
 
 primCall
        :: [ExtFCode (CmmFormal,MachHint)]
        -> FastString
        -> [ExtFCode (CmmExpr,MachHint)]
-       -> Maybe [GlobalReg] -> P ExtCode
-primCall results_code name args_code vols
+       -> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+primCall results_code name args_code vols srt
   = case lookupUFM callishMachOps name of
        Nothing -> fail ("unknown primitive " ++ unpackFS name)
        Just p  -> return $ do
                results <- sequence results_code
                args <- sequence args_code
-               code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
+               code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
 
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code