[Initial FFI export support - works only for trivial cases
Einar Karttunen <ekarttun@cs.helsinki.fi>**20060508155325] addfile ./C/FFI.hs
hunk ./C/FFI.hs 1
+module C.FFI
+    (CallConv(..), Safety(..), FfiType(..), FfiExport(..), FfiSpec(..), Requires(..), nullRequires
+    ) where
+
+import Binary
+import Data.Generics
+import Data.Monoid
+
+type CName    = String
+
+data CallConv = CCall | StdCall | Primitive deriving(Eq,Ord,Show,Data,Typeable)
+    {-! derive: GhcBinary !-}
+
+data Safety = Safe | Unsafe deriving(Eq,Ord,Show,Data,Typeable)
+    {-! derive: GhcBinary !-}
+
+data FfiType = Import CName Requires
+             | ImportAddr CName Requires
+             | Wrapper
+             | Dynamic
+             deriving(Eq,Ord,Show,Data,Typeable)
+             {-! derive: GhcBinary !-}
+
+data Requires = Requires {
+    reqIncludes :: [String],
+    reqLibraries :: [String]
+    } deriving(Typeable, Data, Eq, Ord, Show)
+    {-! derive: Monoid, GhcBinary !-}
+
+nullRequires = Requires [] []
+
+data FfiSpec = FfiSpec FfiType Safety CallConv
+             deriving(Eq,Ord,Show,Data,Typeable)
+             {-! derive: GhcBinary !-}
+
+data FfiExport = FfiExport CName Safety CallConv
+             deriving(Eq,Ord,Show,Data,Typeable)
+             {-! derive: GhcBinary !-}
+
hunk ./C/FromGrin.hs 10
+import qualified Data.Map as Map
hunk ./C/FromGrin.hs 17
+import C.FFI
hunk ./C/FromGrin.hs 383
+
+convertFfiExport :: (Atom,Lam) -> FfiExport -> C Function
+convertFfiExport (n,Tup as :-> body) (FfiExport cn Safe CCall) = do
+        s <- localTodo TodoReturn (convertBody body)
+        let bt = getType body
+            mmalloc (TyPtr _) = [Attribute "A_MALLOC"]
+            mmalloc TyNode = [Attribute "A_MALLOC"]
+            mmalloc _ = []
+            ats = Public : mmalloc bt
+        fr <- convertType bt
+        as' <- flip mapM as $ \ (Var v t) -> do
+            t' <- convertType t
+            return (varName v,t')
+        return $ function (name cn) fr as' ats (profile_function_inc `mappend` s)
+
+
hunk ./C/FromGrin.hs 409
-        funcs <- mapM convertFunc $ grinFunctions grin
+        funcs <- flip mapM (grinFunctions grin) $ \(a,l) -> do
+                   case Map.lookup a (grinEntryPoints grin) of
+                     Nothing -> convertFunc  (a,l)
+                     Just fe -> convertFfiExport (a,l) fe
hunk ./C/Prims.hs 3
+import C.FFI(Requires(..))
hunk ./C/Prims.hs 10
-data Requires = Requires {
-    reqIncludes :: [String],
-    reqLibraries :: [String]
-    } deriving(Typeable, Data, Eq, Ord, Show)
-    {-! derive: Monoid, GhcBinary !-}
hunk ./E/FromHs.hs 27
+import C.FFI
hunk ./E/FromHs.hs 73
-theMainName = toName Name.Val "theMain"
hunk ./E/FromHs.hs 194
-getMainFunction dataTable name ds = ans where
+getMainFunction dataTable name ds = do
+  mt <- Map.lookup name ds
+  funcs <- fmapM (\n -> liftM fst $ Map.lookup n ds) sFuncNames
+  nameToEntryPoint dataTable (fst mt) (toName Name.Val "theMain") (FfiExport "_amain" Safe CCall) funcs
+
+nameToEntryPoint :: Monad m => DataTable -> TVr -> Name -> FfiExport -> FuncNames TVr -> m (Name,TVr,E)
+nameToEntryPoint dataTable main cname ffi ds = ans where
hunk ./E/FromHs.hs 202
-        main <- findName name
-        runMain <- findName (func_runMain sFuncNames)
-        runExpr <- findName (func_runExpr sFuncNames)
-        runNoWrapper <- findName (func_runNoWrapper sFuncNames)
+        let runMain      = func_runMain ds
+            runExpr      = func_runExpr ds
+            runNoWrapper = func_runNoWrapper ds
hunk ./E/FromHs.hs 211
-            theMain = (theMainName,setProperty prop_EXPORTED theMainTvr,ne)
-            theMainTvr =  tVr (toId theMainName) (infertype dataTable ne)
+            theMainTvr =  tVr (toId cname) (infertype dataTable ne)
hunk ./E/FromHs.hs 215
-        return theMain
+        return (cname, tvrInfo_u (Info.insert ffi) $ setProperty prop_EXPORTED theMainTvr,ne)
hunk ./E/FromHs.hs 220
-    findName name = case Map.lookup name ds of
-        Nothing -> fail $ "Cannot find: " ++ show name
-        Just (n,_) -> return n
hunk ./E/FromHs.hs 390
-    cDecl (HsForeignDecl _ i@(Import {}) HS.Primitive _ n _) = do
+    cDecl (HsForeignDecl _ (FfiSpec (Import cn req) _ Primitive) n _) = do
hunk ./E/FromHs.hs 394
-            toPrim (Import cn is ls) = APrim (PrimPrim cn) (Requires is ls)
+            prim      = APrim (PrimPrim cn) req
hunk ./E/FromHs.hs 396
-        let result    = foldr ($) (processPrimPrim dataTable $ EPrim (toPrim i) (map EVar es) rt) (map ELam es)
+        let result    = foldr ($) (processPrimPrim dataTable $ EPrim prim (map EVar es) rt) (map ELam es)
hunk ./E/FromHs.hs 398
-    cDecl (HsForeignDecl _ i@HS.AddrOf {} _ _ n _) = do
+    cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do
hunk ./E/FromHs.hs 405
-            prim       = APrim (CP.AddrOf cn) (Requires is ls) where HS.AddrOf cn is ls = i
+            prim       = APrim (AddrOf rcn) req
hunk ./E/FromHs.hs 407
-    cDecl (HsForeignDecl _ i@Import {} HS.CCall _ n _) = do
+    cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) _ CCall) n _) = do
hunk ./E/FromHs.hs 418
-            prim io rs rtt = EPrim (APrim (Func io s (snds rs) rtt) (Requires is ls))
-                where Import s is ls = i
+            prim io rs rtt = EPrim (APrim (Func io rcn (snds rs) rtt) req)
hunk ./E/FromHs.hs 435
+    cDecl (HsForeignExport _ ffi@(FfiExport ecn _ CCall) n _) = do
+        return . (:[]) =<< nameToEntryPoint dataTable (tv n) (toName Name.FfiExportName ecn) ffi =<< fmapM (return . toTVr assumps) sFuncNames
+    cDecl x@HsForeignExport {} = fail ("Unsupported foreign export: "++ show x)
hunk ./E/WorkerWrapper.hs 95
-    vars@(~[sv]) = [  tVr i t | t <- slotTypes dataTable (fromJust cname) bodyTyp | i <- [2,4..] ]
+    getName (Just x) = x
+    getName Nothing  = error ("workWrap': cname = Nothing: tvr = "++show tvr)
+    vars@(~[sv]) = [  tVr i t | t <- slotTypes dataTable (getName cname) bodyTyp | i <- [2,4..] ]
hunk ./FrontEnd/Desugar.hs 142
-desugarDecl (HsForeignDecl a b c d e qt) = do
+desugarDecl (HsForeignDecl a b c qt) = do
hunk ./FrontEnd/Desugar.hs 144
-    return [HsForeignDecl a b c d e qt]
+    return [HsForeignDecl a b c qt]
+desugarDecl (HsForeignExport a b c qt) = do
+    qt <- remSynsQualType qt
+    return [HsForeignExport a b c qt]
hunk ./FrontEnd/HsParser.ly 20
+> import C.FFI
hunk ./FrontEnd/HsParser.ly 293
->                          return (HsForeignDecl $2 x $4 Safe $6 $8) }
+>                          return (HsForeignExport $2 (FfiExport x Safe $4) $6 $8) }
hunk ./FrontEnd/HsParser.ly 295
->                       { let i = Import (if null $5 then show $6 else $5) [] []
->                         in HsForeignDecl $2 i Primitive Safe $6 $8 }
+>                       { let i = Import (if null $5 then show $6 else $5) nullRequires
+>                         in HsForeignDecl $2 (FfiSpec i Safe Primitive) $6 $8 }
hunk ./FrontEnd/HsParser.ly 299
->                          return (HsForeignDecl $2 x $4 $5 $7 $9) }
+>                          return (HsForeignDecl $2 (FfiSpec x $5 $4) $7 $9) }
hunk ./FrontEnd/HsPretty.hs 273
-ppHsDecl fd@(HsForeignDecl _ _ _ _ n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
+ppHsDecl fd@(HsForeignDecl _ _ n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
+ppHsDecl fd@(HsForeignExport _ _ n qt) = text "ForeignExport" <+> ppHsName n <+> ppHsQualType qt <+> text (show fd)
hunk ./FrontEnd/HsSyn.hs 7
+import C.FFI
hunk ./FrontEnd/HsSyn.hs 35
--- Foreign Declarations
-
-data Safety = Safe | Unsafe deriving(Data,Eq,Ord,Show,Typeable)
-data CallConv = CCall | StdCall | Primitive deriving(Data,Eq,Ord,Show,Typeable)
-type Includes = [String]
-type Libs     = [String]
-type CName    = String
-
-data HsForeignT = AddrOf CName Libs Includes
-                | Dynamic
-                | Export CName
-                | Import CName Libs Includes
-                | Wrapper
-                  deriving(Data,Eq,Ord,Show,Typeable)
-
hunk ./FrontEnd/HsSyn.hs 133
+    srcLoc (HsForeignExport sl _ _ _) = sl
hunk ./FrontEnd/HsSyn.hs 157
-                           hsDeclForeign  :: HsForeignT,
-                           hsDeclCallConv :: CallConv,
-                           hsDeclSafety   :: Safety,
+                           hsDeclForeign  :: FfiSpec,
hunk ./FrontEnd/HsSyn.hs 161
+         | HsForeignExport SrcLoc FfiExport HsName HsQualType
hunk ./FrontEnd/HsSyn.hs 168
-
hunk ./FrontEnd/ParseUtils.hs 40
+import C.FFI
hunk ./FrontEnd/ParseUtils.hs 368
-parseExport :: Monad m => String -> HsName -> m HsForeignT
+parseExport :: Monad m => String -> HsName -> m String
hunk ./FrontEnd/ParseUtils.hs 371
-      [x] | isCName x -> return $ Export x
-      []              -> return $ Export $ show hn
+      [x] | isCName x -> return x
+      []              -> return (show hn)
hunk ./FrontEnd/ParseUtils.hs 375
-parseImport :: Monad m => String -> HsName -> m HsForeignT
+parseImport :: Monad m => String -> HsName -> m FfiType
hunk ./FrontEnd/ParseUtils.hs 380
-      []            -> return $ Import (show hn) [] []
+      []            -> return $ Import (show hn) nullRequires
hunk ./FrontEnd/ParseUtils.hs 384
-parseIS a b ['&':n] | isCName n = return $ AddrOf n a b
-parseIS a b [n]     | isCName n = return $ Import n a b
-parseIS a b ["&",n] | isCName n = return $ AddrOf n a b
+parseIS a b ['&':n] | isCName n = return $ ImportAddr n $ Requires a b
+parseIS a b [n]     | isCName n = return $ Import     n $ Requires a b
+parseIS a b ["&",n] | isCName n = return $ ImportAddr n $ Requires a b
hunk ./FrontEnd/Rename.hs 286
-renameHsDecl (HsForeignDecl a b c d n t) subTable = do
+renameHsDecl (HsForeignExport a b n t) subTable = do
hunk ./FrontEnd/Rename.hs 291
-    return (HsForeignDecl a b c d n t)
+    return (HsForeignExport a b n t)
+
+renameHsDecl (HsForeignDecl a b n t) subTable = do
+    setSrcLoc a
+    n <- renameHsName n subTable
+    subTable' <- updateSubTableWithHsQualType subTable t
+    t <- renameHsQualType t subTable'
+    return (HsForeignDecl a b n t)
hunk ./FrontEnd/Rename.hs 1072
-getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ _ n _) = [(n,a)]
+getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ n _) = [(n,a)]
hunk ./FrontEnd/Rename.hs 1095
-    f (HsForeignDecl a _ _ _ n _)  = tellF [(toName Val n,a,[])]
+    f (HsForeignDecl a _ n _)  = tellF [(toName Val n,a,[])]
+    f (HsForeignExport a e _ _)  = tellF [(ffiExportName e,a,[])]
hunk ./FrontEnd/Rename.hs 1153
-namesHsDecl (HsForeignDecl a _ _ _ n _)  = ([(n,a)],[])
+namesHsDecl (HsForeignDecl a _ n _)  = ([(n,a)],[])
hunk ./FrontEnd/Tc/Main.hs 565
-tcPragmaDecl fd@(HsForeignDecl _ _ _ _ n qt) = do
+tcPragmaDecl fd@(HsForeignDecl _ _ n qt) = do
hunk ./FrontEnd/Tc/Main.hs 571
+tcPragmaDecl fd@(HsForeignExport _ e n qt) = do
+    kt <- getKindEnv
+    s <- hsQualTypeToSigma kt qt
+    addToCollectedEnv (Map.singleton (ffiExportName e) s)
+    return [fd]
+
hunk ./FrontEnd/Tc/Main.hs 675
+tiExpl (sc, decl@HsForeignExport {}) = do return (decl,Map.empty)
hunk ./FrontEnd/Tc/Module.hs 250
-    let externalEnv = Map.filterWithKey (\ x _ -> isGlobal x && (fromJust (getModule x) `elem` map modInfoName ms)) localVarEnv `Map.union` noDefaultSigs
+    let getMod x = case getModule x of
+                     Just m  -> m
+                     Nothing -> error ("getModule "++show x++" => Nothing")
+        interesting x = isGlobal x && nameType x /= FfiExportName
+    let externalEnv = Map.filterWithKey (\ x _ -> interesting x && (getMod x `elem` map modInfoName ms)) localVarEnv `Map.union` noDefaultSigs
hunk ./FrontEnd/Tc/Module.hs 256
-    let externalKindEnv = restrictKindEnv (\ x  -> isGlobal x && (fromJust (getModule x) `elem` map modInfoName ms)) kindInfo
+    let externalKindEnv = restrictKindEnv (\ x  -> interesting x && (getMod x `elem` map modInfoName ms)) kindInfo
hunk ./FrontEnd/TypeSigs.hs 52
-collectSigsFromDecls ((HsForeignDecl sl _ _ _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds
+collectSigsFromDecls ((HsForeignDecl   sl _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds
+collectSigsFromDecls ((HsForeignExport sl _ n qt):ds) = HsTypeSig sl [n] qt:collectSigsFromDecls ds
hunk ./FrontEnd/TypeSyns.hs 102
-renameHsDecl (HsForeignDecl a b c d n t) subTable = withSrcLoc a $ do
+renameHsDecl (HsForeignDecl a b n t) subTable = withSrcLoc a $ do
hunk ./FrontEnd/TypeSyns.hs 105
-    return  (HsForeignDecl a b c d n t)
+    return  (HsForeignDecl a b n t)
+
+renameHsDecl (HsForeignExport a b n t) subTable = withSrcLoc a $ do
+    n <- renameHsName n subTable
+    t <- renameHsQualType t subTable
+    return  (HsForeignExport a b n t)
hunk ./FrontEnd/TypeSyns.hs 503
-getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ _ _ n _) = [(n,a)]
+getHsNamesAndASrcLocsFromHsDecl (HsForeignDecl a _ n _) = [(n,a)]
hunk ./FrontEnd/Utils.hs 35
+maybeGetDeclName (HsForeignExport _ e _ _)   = return $ ffiExportName e
hunk ./Grin/FromE.hs 16
+import qualified C.FFI as FFI
hunk ./Grin/FromE.hs 124
-compile prog@Program { progDataTable = dataTable, progMainEntry = mainEntry } = do
+compile prog@Program { progDataTable = dataTable, progMainEntry = mainEntry, progEntryPoints = entries } = do
hunk ./Grin/FromE.hs 157
+
+    -- FFI
+    let tvrAtom (TVr i _ _)  = intToAtom i
+    let ef x = do n <- tvrAtom x
+                  return (n, Tup [] :-> discardResult (App (scTag x) [] tyUnit))
+        ep x = do putStrLn ("EP FOR "++show x)
+                  n <- tvrAtom x
+                  l <- Info.lookup (tvrInfo x)
+                  return (n, l)
+    efv <- mapM ef $ tail entries -- FIXME
+    epv <- mapM ep entries
+    enames <- mapM tvrAtom entries
+
+
hunk ./Grin/FromE.hs 172
-    let newTyEnv = TyEnv $ Map.fromList $ concatMap makePartials (Map.toList endTyEnv)
+    -- FIXME correct types.
+    let newTyEnv = TyEnv $ Map.fromList (concatMap makePartials (Map.toList endTyEnv) ++ [(en, ([],tyUnit)) | en <- enames])
hunk ./Grin/FromE.hs 181
-    let ep s = Set.fromList $ concatMap partialLadder $ Set.toList s
+    let -- ep s = Set.fromList $ concatMap partialLadder $ Set.toList s
hunk ./Grin/FromE.hs 187
+
hunk ./Grin/FromE.hs 189
-            grinEntryPoints = [funcMain],
+            grinEntryPoints = Map.fromList epv,
hunk ./Grin/FromE.hs 192
-            grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] tyUnit :>>= unit :->  discardResult theMain)) : ds',
+            grinFunctions = (head enames ,(Tup [] :-> App funcInitCafs [] tyUnit :>>= unit :->  discardResult theMain)) : efv ++ ds',
hunk ./Grin/FromE.hs 233
-    (funcMain, ([],tyUnit)),
hunk ./Grin/Grin.hs 28
+    grinEntryPointNames,
hunk ./Grin/Grin.hs 69
+import C.FFI
hunk ./Grin/Grin.hs 206
-    grinEntryPoints :: [Atom],
+    grinEntryPoints :: Map.Map Atom FfiExport,
hunk ./Grin/Grin.hs 219
-    grinEntryPoints = [],
+    grinEntryPoints = mempty,
hunk ./Grin/Grin.hs 230
+grinEntryPointNames = Map.keys . grinEntryPoints
+
hunk ./Grin/PointsToAnalysis.hs 396
-funcReturn te pt fn vs = valueSetToItem te pt ty vs where
-    Just (_,ty) = findArgsType te fn
+funcReturn te pt fn vs =
+  case findArgsType te fn of
+    Just (_,ty) -> valueSetToItem te pt ty vs
+    Nothing     -> error ("funcReturn: "++show fn)
hunk ./Grin/Show.hs 172
-        ++ (if x `elem` grinEntryPoints grin then [("shape","box")] else [])
+        ++ (if x `elem` grinEntryPointNames grin then [("shape","box")] else [])
hunk ./Grin/Simplify.hs 498
-        rf = reachable graph (grinEntryPoints grin)
+        rf = reachable graph (grinEntryPointNames grin)
hunk ./Main.hs 526
-    prog <- return prog { progMainEntry = main, progEntryPoints = [main], progCombinators = (main,[],mainv):[ (unsetProperty prop_EXPORTED t,as,e) | (t,as,e) <- progCombinators prog] }
+    let ffiExportNames = filter (\t -> (tvrName t >>= return . nameType) == Just FfiExportName) $ map (\(x,_,_) -> x) $ progCombinators prog
+    prog <- return prog { progMainEntry   = main,
+                          progEntryPoints = (main:ffiExportNames),
+                          progCombinators = (main,[],mainv):[ (unsetProperty prop_EXPORTED t,as,e) | (t,as,e) <- progCombinators prog]
+                        }
hunk ./Main.hs 655
-    x <- deadCode stats (grinEntryPoints x) x  -- XXX
+    x <- deadCode stats (grinEntryPointNames x) x  -- XXX
hunk ./Main.hs 661
-    x <- deadCode stats (grinEntryPoints x) x  -- XXX
+    x <- deadCode stats (grinEntryPointNames x) x  -- XXX
hunk ./Main.hs 682
-        x <- deadCode stats (grinEntryPoints x) x
+        x <- deadCode stats (grinEntryPointNames x) x
hunk ./Main.hs 689
-        x <- deadCode stats (grinEntryPoints x) x
+        x <- deadCode stats (grinEntryPointNames x) x
hunk ./Name/Name.hs 13
+    ffiExportName,
hunk ./Name/Name.hs 30
+import C.FFI
hunk ./Name/Name.hs 45
+    | FfiExportName -- Name is the C name of a FFI export
hunk ./Name/Name.hs 77
+createUName :: NameType -> String -> Name
hunk ./Name/Name.hs 179
-
+ffiExportName :: FfiExport -> Name
+ffiExportName (FfiExport cn _ _) = toName FfiExportName cn
hunk ./data/jhc_rts.c 45
-static void _amain(void) A_REGPARM;
+static void _amain(void);