ffi: init

Author: rockofox

Diff for: .hlint.yaml

@@ -59,6 +59,7 @@
 # Ignore some builtin hints
 # - ignore: {name: Use let}
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+- ignore: {name: Use fewer imports, within: Ffi}
 
 
 # Define some custom infix operators

Diff for: examples/ffi.in

@@ -0,0 +1,14 @@
+external "sayhello" = do
+    greet :: String -> IO
+    printNumbers :: List{Int} -> Int -> IO
+    printf :: String -> Int -> IO
+end
+external "__default" = do
+    puts :: List{Char} -> IO
+end
+
+let main = do
+    puts ['H', 'e', 'l', 'l', 'o', ' ', 'W', 'o', 'r', 'l', 'd', '!', '\0']
+    printNumbers [1, 2, 3, 4, 5], 5
+    printf "Hello, %d!\n", 42
+end

Diff for: indigo.cabal

@@ -17,6 +17,10 @@ common warnings
     -- ghc-options: -Wall -Wno-incomplete-uni-patterns -O0 -fno-code
     ghc-options: -Wall -Wno-incomplete-uni-patterns
 
+flag ffi
+    description: FFI
+    default: True
+
 library
     import:           warnings
     exposed-modules: , Parser
@@ -26,6 +30,7 @@ library
                      , Verifier
                      , Util
                      , RegInst
+                     , Ffi
     other-modules: Paths_indigo
     build-depends: base,
         containers,
@@ -44,6 +49,12 @@ library
         executable-path,
         filepath,
         random
+    if flag(ffi)
+        build-depends:
+            libffi,
+            unix
+        cpp-options: -DFFI
+
     hs-source-dirs:   lib
     default-language: Haskell2010
     default-extensions: OverloadedStrings,

Diff for: indigo.vim

@@ -37,7 +37,7 @@ syn region  inImportList start='(' skip='([^)]\{-})' end=')' keepend contained c
 
 syn keyword inImportMod contained as qualified hiding
 syn keyword inInfix as
-syn keyword inStructure struct trait impl for let
+syn keyword inStructure struct trait impl for let external
 syn keyword inTypedef type
 syn keyword inNewtypedef newtype
 syn keyword inTypeFam family

Diff for: lib/AST.hs

@@ -2,6 +2,7 @@ module AST where
 
 import Data.Binary qualified
 import GHC.Generics (Generic)
+import VM qualified
 
 data Expr
     = Var String Position
@@ -54,6 +55,8 @@ data Expr
     | Trait {name :: String, methods :: [Expr]}
     | Impl {trait :: String, for :: String, methods :: [Expr]}
     | StrictEval Expr
+    | External String [Expr]
+    | CharLit Char
     deriving
         ( Show
         , Generic
@@ -111,6 +114,8 @@ children (Trait _ a) = a
 children (Impl _ _ a) = a
 children (FuncDec _ _) = []
 children (StrictEval a) = [a]
+children (External _ a) = a
+children (CharLit _) = []
 
 newtype Position = Position (Int, Int) deriving (Show, Generic, Ord)
 
@@ -133,6 +138,7 @@ data Type
     | Float
     | Bool
     | String
+    | Char
     | Any
     | None
     | Unknown
@@ -154,6 +160,7 @@ instance Show Type where
     show (List t) = "List{" ++ show t ++ "}"
     show (StructT structName) = structName
     show Self = "Self"
+    show Char = "Char"
 
 newtype Program = Program {exprs :: [Expr]} deriving (Show, Eq, Generic)
 
@@ -227,6 +234,17 @@ typeOf (Trait _ _) = error "Cannot infer type of trait"
 typeOf (Impl{}) = error "Cannot infer type of impl"
 typeOf (Then _ b) = typeOf b
 typeOf (StrictEval x) = typeOf x
+typeOf (External _ _) = error "Cannot infer type of external"
+typeOf (CharLit _) = Char
+
+typeToData :: Type -> VM.Data
+typeToData Int = VM.DInt 0
+typeToData Float = VM.DFloat 0
+typeToData Bool = VM.DBool False
+typeToData String = VM.DString ""
+typeToData (StructT "IO") = VM.DNone -- Hmmm...
+typeToData Char = VM.DChar ' '
+typeToData x = error $ "Cannot convert type " ++ show x ++ " to data"
 
 -- typeOf x = error $ "Cannot infer type of " ++ show x
 

Diff for: lib/BytecodeCompiler.hs

@@ -1,7 +1,7 @@
 -- module BytecodeCompiler (runTestProgram, locateLabel, printAssembly, compileProgram, CompilerState (..), Function) where
 module BytecodeCompiler where
 
-import AST (zeroPosition)
+import AST (typeToData, zeroPosition)
 import AST qualified as Parser.Type (Type (Unknown))
 import Control.Monad (when, (>=>))
 import Control.Monad.Loops (firstM)
@@ -12,6 +12,7 @@ import Data.Maybe (fromJust, isJust, isNothing)
 import Data.Text (isPrefixOf, splitOn)
 import Data.Text qualified
 import Data.Text qualified as T
+import Debug.Trace
 import Foreign ()
 import Foreign.C.Types ()
 import GHC.Generics (Generic)
@@ -35,6 +36,14 @@ data Function = Function
     }
     deriving (Show, Generic)
 
+data External = External
+    { name :: String
+    , returnType :: Parser.Type
+    , args :: [Parser.Type]
+    , from :: String
+    }
+    deriving (Show)
+
 data CompilerState a = CompilerState
     { program :: Parser.Program
     , -- , functions :: [(String, String, [Instruction])]
@@ -46,6 +55,7 @@ data CompilerState a = CompilerState
     , traits :: [Parser.Expr]
     , impls :: [Parser.Expr]
     , currentContext :: String -- TODO: Nested contexts
+    , externals :: [External]
     }
     deriving (Show)
 
@@ -57,7 +67,7 @@ data Let = Let
     deriving (Show)
 
 initCompilerState :: Parser.Program -> CompilerState a
-initCompilerState prog = CompilerState prog [] [] [] 0 [] [] [] "__outside"
+initCompilerState prog = CompilerState prog [] [] [] 0 [] [] [] "__outside" []
 
 allocId :: StateT (CompilerState a) IO Int
 allocId = do
@@ -217,32 +227,39 @@ compileExpr (Parser.FuncCall funcName args _) = do
     functions' <- gets functions
     funcDecs' <- gets funcDecs
     curCon <- gets currentContext
+    externals' <- gets externals
     let fun = case findFunction (curCon ++ "@" ++ funcName) functions' argTypes of
             (Just lf) -> lf
             Nothing -> case findFunction funcName functions' argTypes of
                 (Just f) -> f
                 Nothing -> Function{baseName = unmangleFunctionName funcName, funame = funcName, function = [], types = []}
     let funcDec = find (\(Parser.FuncDec name' _) -> name' == baseName fun) funcDecs'
-
+    let external = find (\x -> x.name == funcName) externals'
     -- If the funcName starts with curCon@, it's a local function
     let callWay = (if T.pack (curCon ++ "@") `isPrefixOf` T.pack fun.funame then CallLocal (funame fun) else Call (funame fun))
 
-    case funcDec of
-        (Just fd) -> do
-            if length args == length (Parser.types fd) - 1
-                then concatMapM compileExpr args >>= \args' -> return (args' ++ [callWay])
-                else
+    case external of
+        Just (External _ ereturnType _ from) -> do
+            let retT = typeToData ereturnType
+            args' <- concatMapM compileExpr (reverse args)
+            return $ [Push retT] ++ args' ++ [CallFFI funcName from (length args)]
+        Nothing ->
+            case funcDec of
+                (Just fd) -> do
+                    if length args == length (Parser.types fd) - 1
+                        then concatMapM compileExpr args >>= \args' -> return (args' ++ [callWay])
+                        else
+                            concatMapM compileExpr args >>= \args' ->
+                                return $
+                                    args'
+                                        ++ [PushPf (funame fun) (length args')]
+                Nothing ->
                     concatMapM compileExpr args >>= \args' ->
                         return $
                             args'
-                                ++ [PushPf (funame fun) (length args')]
-        Nothing ->
-            concatMapM compileExpr args >>= \args' ->
-                return $
-                    args'
-                        ++ [ LLoad funcName
-                           , CallS
-                           ]
+                                ++ [ LLoad funcName
+                                   , CallS
+                                   ]
 compileExpr fd@(Parser.FuncDec _ _) = do
     modify (\s -> s{funcDecs = fd : funcDecs s})
     return [] -- Function declarations are only used for compilation
@@ -303,10 +320,11 @@ compileExpr (Parser.FuncDef origName args body) = do
 compileExpr (Parser.Var x _) = do
     functions' <- gets functions
     curCon <- gets currentContext
+    externals' <- gets externals
     -- traceM $ "Looking for " ++ x ++ " in " ++ show (map baseName functions')
     -- traceM $ "Looking for " ++ curCon ++ "@" ++ x ++ " in " ++ show (map baseName functions')
     let fun = any ((== x) . baseName) functions' || any ((== curCon ++ "@" ++ x) . baseName) functions'
-    if fun || x `elem` internalFunctions
+    if fun || x `elem` internalFunctions || x `elem` map (\f -> f.name) externals'
         then compileExpr (Parser.FuncCall x [] zeroPosition)
         else return [LLoad x]
 compileExpr (Parser.Let name value) = do
@@ -416,6 +434,12 @@ compileExpr (Parser.Then a b) = do
     b' <- compileExpr b
     return $ a' ++ b'
 compileExpr (Parser.UnaryMinus x) = compileExpr x >>= \x' -> return (x' ++ [Push $ DInt (-1), Mul])
+compileExpr (Parser.External _ []) = return []
+compileExpr (Parser.External from ((Parser.FuncDec name types) : xs)) = do
+    modify (\s -> s{externals = External{name, returnType = last types, args = init types, from} : externals s})
+    _ <- compileExpr (Parser.External from xs)
+    return []
+compileExpr (Parser.CharLit x) = return [Push $ DChar x]
 compileExpr x = error $ show x ++ " is not implemented"
 
 createVirtualFunctions :: StateT (CompilerState a) IO ()

Diff for: lib/FFI.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE CPP #-}
+
+module Ffi where
+
+import Foreign.Ptr (FunPtr)
+
+#if defined(MIN_VERSION_Win32)
+import Control.Exception (bracket)
+import Foreign.Ptr (castPtrToFunPtr)
+import System.Win32.DLL
+import System.Win32.Types (HMODULE)
+#else
+import System.Posix.DynamicLinker
+#endif
+
+-- | The dynamic library containing the C runtime.
+crtPath :: FilePath
+#if defined(mingw32_HOST_OS)
+crtPath = "msvcrt.dll"
+#elif defined(darwin_HOST_OS)
+crtPath = "libc.dylib"
+#else
+-- On other OSes, it suffices to use the name of the current
+-- executable, as the dyanmic loader can chase dependencies until it
+-- finds the C runtime.
+crtPath = ""
+#endif
+
+-- | The file extension used for dynamic libraries.
+dllext :: String
+#if defined(mingw32_HOST_OS)
+dllext = "dll"
+#elif defined(darwin_HOST_OS)
+dllext = "dylib"
+#else
+dllext = "so"
+#endif
+
+-- | The Haskell representation of a loaded dynamic library.
+#if defined(MIN_VERSION_Win32)
+type DynLib = HMODULE
+#else
+type DynLib = DL
+#endif
+
+-- | Return the address of a function symbol contained in a dynamic library.
+dynLibSym :: DynLib -> String -> IO (FunPtr a)
+#if defined(MIN_VERSION_Win32)
+dynLibSym source symbol = do
+  addr <- getProcAddress source symbol
+  return $ castPtrToFunPtr addr
+#else
+dynLibSym = dlsym
+#endif
+
+-- | Load a dynamic library, perform some action on it, and then free it.
+withDynLib :: FilePath -> (DynLib -> IO a) -> IO a
+#if defined(MIN_VERSION_Win32)
+withDynLib file f = bracket (loadLibrary file) freeLibrary f
+#else
+withDynLib file = withDL file [RTLD_NOW]
+#endif
+
+-- | Open a dynamic library.
+dynLibOpen :: FilePath -> IO DynLib
+#if defined(MIN_VERSION_Win32)
+dynLibOpen = loadLibrary
+#else
+dynLibOpen x = dlopen x [RTLD_NOW]
+#endif

Diff for: lib/Parser.hs

@@ -207,6 +207,9 @@ validType =
         <|> do
             keyword "Self"
             return Self
+        <|> do
+            keyword "Char"
+            return Char
         <|> do
             lookAhead $ satisfy isUpper
             StructT <$> identifier
@@ -215,6 +218,9 @@ validType =
 stringLit :: Parser String
 stringLit = lexeme $ char '\"' *> manyTill L.charLiteral (char '\"')
 
+charLit :: Parser Char
+charLit = lexeme $ char '\'' *> L.charLiteral <* char '\''
+
 funcDec :: Parser Expr
 funcDec = do
     name <- identifier <|> gravis
@@ -457,6 +463,17 @@ impl = do
     symbol "end"
     return $ Impl name for methods
 
+external :: Parser Expr
+external = do
+    keyword "external"
+    from <- stringLit
+    symbol "="
+    symbol "do"
+    newline'
+    decs <- funcDec `sepEndBy` newline'
+    symbol "end"
+    return $ External from decs
+
 term :: Parser Expr
 term =
     choice
@@ -465,10 +482,12 @@ term =
         , FloatLit <$> try float
         , IntLit <$> try integer
         , StringLit <$> try stringLit
+        , CharLit <$> try charLit
         , symbol "True" >> return (BoolLit True)
         , symbol "False" >> return (BoolLit False)
         , -- , letExpr
-          struct
+          external
+        , struct
         , import_
         , doBlock
         , impl