Add PrimCall to the STG layer and update Core -> STG translation

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index f9976b4..ef48bb4 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -240,12 +240,13 @@ incorrect.
  'label'       { L _ ITlabel } 
  'dynamic'     { L _ ITdynamic }
  'safe'                { L _ ITsafe }
- 'threadsafe'  { L _ ITthreadsafe }
+ 'threadsafe'  { L _ ITthreadsafe }  -- ToDo: remove deprecated alias
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'family'      { L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
+ 'prim'         { L _ ITprimcallconv }
  'dotnet'       { L _ ITdotnet }
  'proc'                { L _ ITproc }          -- for arrow notation extension
  'rec'         { L _ ITrec }           -- for arrow notation extension
@@ -952,12 +953,13 @@ fdecl : 'import' callconv safety fspec
 callconv :: { CallConv }
          : 'stdcall'                   { CCall  StdCallConv }
          | 'ccall'                     { CCall  CCallConv   }
+         | 'prim'                      { CCall  PrimCallConv}
          | 'dotnet'                    { DNCall             }
 
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe  False }
-       | 'threadsafe'                  { PlaySafe  True }
+       | 'threadsafe'                  { PlaySafe  True } -- deprecated alias
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        : STRING var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
@@ -1150,9 +1152,9 @@ gadt_constrlist :: { Located [LConDecl RdrName] }
        |     vocurly    gadt_constrs close     { $2 }
 
 gadt_constrs :: { Located [LConDecl RdrName] }
-        : gadt_constrs ';' gadt_constr  { LL ($3 : unLoc $1) }
+        : gadt_constrs ';' gadt_constr  { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) }
         | gadt_constrs ';'             { $1 }
-        | gadt_constr                   { L1 [$1] } 
+        | gadt_constr                   { sL (getLoc (head $1)) $1 } 
 
 -- We allow the following forms:
 --     C :: Eq a => a -> T a
@@ -1160,15 +1162,15 @@ gadt_constrs :: { Located [LConDecl RdrName] }
 --     D { x,y :: a } :: T a
 --     forall a. Eq a => D { x,y :: a } :: T a
 
-gadt_constr :: { LConDecl RdrName }
-        : con '::' sigtype
-              { LL (mkGadtDecl $1 $3) } 
+gadt_constr :: { [LConDecl RdrName] }
+        : con_list '::' sigtype
+                { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } 
         -- Syntax: Maybe merge the record stuff with the single-case above?
         --         (to kill the mostly harmless reduce/reduce error)
         -- XXX revisit audreyt
        | constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $1 in 
-                 LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing) }
+                 [LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing)] }
 {-
        | forall context '=>' constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $4 in 
@@ -1728,6 +1730,10 @@ con      :: { Located RdrName }
        | '(' consym ')'        { LL (unLoc $2) }
        | sysdcon               { L1 $ nameRdrName (dataConName (unLoc $1)) }
 
+con_list :: { Located [Located RdrName] }
+con_list : con                  { L1 [$1] }
+         | con ',' con_list     { LL ($1 : unLoc $3) }
+
 sysdcon        :: { Located DataCon }  -- Wired in data constructors
        : '(' ')'               { LL unitDataCon }
        | '(' commas ')'        { LL $ tupleCon Boxed $2 }
@@ -1898,6 +1904,7 @@ special_id
        | 'dynamic'             { L1 (fsLit "dynamic") }
        | 'stdcall'             { L1 (fsLit "stdcall") }
        | 'ccall'               { L1 (fsLit "ccall") }
+       | 'prim'                { L1 (fsLit "prim") }
 
 special_sym :: { Located FastString }
 special_sym : '!'      { L1 (fsLit "!") }