~jojo/Carth

f1a780c27ed97e16f7bbbfd2c52f0d7696e3fab2 — JoJo 1 year, 11 months ago 5cca538
Add external item declarations

To test it out, change print-int from being a builtin to being an
extern function.
M README.org => README.org +2 -4
@@ 25,10 25,8 @@ Visit [[https://carth.jo.zone/][https://carth.jo.zone/]] for an overview of the 
  The Carth compiler needs to link with a foreign core library of
  functions that can't be defined in Carth itself, to do things like
  input/output and pointer manipulation etc. This library is written
  in Rust and is located in "foreign-core/". Build with ~cargo build~,
  and copy the resulting static library from
  "foreign-core/target/debug/libcarth-foreign-core.a" to
  "foreign-core/".
  in Rust and is located in "foreign-core/". Just build with ~cargo
  build~.

* Running
  #+BEGIN_EXAMPLE bash

M examples/test.carth => examples/test.carth +2 -0
@@ 1,2 1,4 @@
(extern print-int (Fun Int Unit))

(define (main _)
  (print-int 123))

M foreign-core/src/lib.rs => foreign-core/src/lib.rs +27 -1
@@ 1,4 1,30 @@
#![feature(const_fn)]

use std::ptr;

pub type Captures = *const ();
pub type ClosureFunc<A, B> = extern "C" fn(Captures, A) -> B;

#[repr(C)]
pub struct Closure<A, B> {
    captures: Captures,
    func: ClosureFunc<A, B>,
}

unsafe impl<A, B> Sync for Closure<A, B> {}

impl<A, B> Closure<A, B> {
    const fn new(f: ClosureFunc<A, B>) -> Closure<A, B> {
        Closure {
            captures: ptr::null(),
            func: f,
        }
    }
}

#[export_name = "print-int"]
pub extern "C" fn print_int(n: i64) {
pub static PRINT_INT: Closure<i64, ()> = Closure::new(print_int);

pub extern "C" fn print_int(_: Captures, n: i64) {
    println!("{}", n)
}

M src/AnnotAst.hs => src/AnnotAst.hs +4 -1
@@ 19,6 19,7 @@ module AnnotAst
    , Expr(..)
    , Defs(..)
    , TypeDefs
    , Externs
    , Program(..)
    )
where


@@ 62,5 63,7 @@ newtype Defs = Defs (Map String (Scheme, Expr))

type TypeDefs = Map String ([TVar], [[Type]])

data Program = Program Expr Defs TypeDefs
type Externs = Map String Type

data Program = Program Expr Defs TypeDefs Externs
    deriving (Show)

M src/Ast.hs => src/Ast.hs +13 -3
@@ 20,6 20,7 @@ module Ast
    , Def
    , ConstructorDefs(..)
    , TypeDef(..)
    , Extern(..)
    , Program(..)
    )
where


@@ 107,7 108,10 @@ newtype ConstructorDefs = ConstructorDefs [(Id Big, [Type])]
data TypeDef = TypeDef (Id Big) [Id Small] ConstructorDefs
    deriving (Show, Eq)

data Program = Program [Def] [TypeDef]
data Extern = Extern (Id Small) Type
    deriving (Show, Eq)

data Program = Program [Def] [TypeDef] [Extern]
    deriving (Show, Eq)




@@ 133,6 137,8 @@ instance HasPos Pat where

instance Pretty Program where
    pretty' = prettyProg
instance Pretty Extern where
    pretty' = prettyExtern
instance Pretty ConstructorDefs where
    pretty' = prettyConstructorDefs
instance Pretty TypeDef where


@@ 181,7 187,7 @@ bvPat = \case
    PVar x -> Set.singleton x

prettyProg :: Int -> Program -> String
prettyProg d (Program defs tdefs) =
prettyProg d (Program defs tdefs externs) =
    let
        prettyDef = \case
            (name, (Just scm, body)) -> concat


@@ 193,7 199,11 @@ prettyProg d (Program defs tdefs) =
                [ indent d ++ "(define " ++ pretty name ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]
    in unlines (map prettyDef defs ++ map pretty tdefs)
    in unlines (map prettyDef defs ++ map pretty tdefs ++ map pretty externs)

prettyExtern :: Int -> Extern -> String
prettyExtern _ (Extern name t) =
    concat ["(extern ", idstr name, " ", pretty t, ")"]

prettyTypeDef :: Int -> TypeDef -> String
prettyTypeDef d (TypeDef name params constrs) = concat

M src/Check.hs => src/Check.hs +20 -14
@@ 65,15 65,11 @@ runInfer' = runExcept . flip runStateT initSt . flip runReaderT initEnv

initEnv :: Env
initEnv = Env
    { _envDefs = builtinSchemes
    { _envDefs = Map.empty
    , _envCtors = Map.empty
    , _envTypeDefs = Map.empty
    }

builtinSchemes :: Map String Scheme
builtinSchemes = Map.fromList
    [("print-int", Forall Set.empty (TFun (TPrim TInt) (TPrim TUnit)))]

initSt :: St
initSt = St { _tvCount = 0, _substs = Map.empty }



@@ 101,20 97,30 @@ withLocal b = locally envDefs (uncurry Map.insert b)
-- Inference
--------------------------------------------------------------------------------
inferProgram :: Ast.Program -> Infer Program
inferProgram (Ast.Program defs tdefs) = do
inferProgram (Ast.Program defs tdefs externs) = do
    (_, (WithPos mainPos _)) <- maybe
        (throwError MainNotDefined)
        pure
        (lookup "main" (map (first idstr) defs))
    (tdefs', ctors) <- checkTypeDefs tdefs
    Defs defs' <-
        augment envTypeDefs tdefs' $ augment envCtors ctors $ inferDefs defs
    let (Forall _ mainT, main) = fromJust (Map.lookup "main" defs')
    let expectedMainType = TFun (TPrim TUnit) (TPrim TUnit)
    unify (Expected expectedMainType) (Found mainPos mainT)
    let defs'' = Map.delete "main" defs'
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Program main (Defs defs'') (tdefs''))
    augment envTypeDefs tdefs' $ augment envCtors ctors $ do
        externs' <- checkExterns externs
        let externs'' = fmap (Forall Set.empty) externs'
        Defs defs' <- augment envDefs externs'' (inferDefs defs)
        let (Forall _ mainT, main) = fromJust (Map.lookup "main" defs')
        let expectedMainType = TFun (TPrim TUnit) (TPrim TUnit)
        unify (Expected expectedMainType) (Found mainPos mainT)
        let defs'' = Map.delete "main" defs'
        let tdefs'' = fmap (second (map snd)) tdefs'
        pure (Program main (Defs defs'') tdefs'' externs')

checkExterns :: [Ast.Extern] -> Infer (Map String Type)
checkExterns = fmap Map.fromList . mapM checkExtern

checkExtern :: Ast.Extern -> Infer (String, Type)
checkExtern (Ast.Extern name t) = case Set.lookupMin (ftv t) of
    Just tv -> throwError (ExternNotMonomorphic name tv)
    Nothing -> pure (idstr name, t)

checkTypeDefs
    :: [Ast.TypeDef]

M src/Codegen.hs => src/Codegen.hs +44 -24
@@ 64,8 64,7 @@ data FunInstruction = WithRetType Instruction Type
--       Update: They are both behind pointers now, right? So we could just have
--       a single map?
data Env = Env
    { _localEnv :: Map TypedVar Operand
    , _globalEnv :: Map TypedVar Operand
    { _env :: Map TypedVar Operand
    }
makeLenses ''Env



@@ 104,10 103,10 @@ instance Pretty Module where


codegen :: FilePath -> Program -> EncodeAST Module
codegen moduleFilePath (Program main (Defs defs) tdefs) = do
codegen moduleFilePath (Program main (Defs defs) tdefs externs) = do
    tdefs' <- defineDataTypes tdefs
    let defs' = (TypedVar "main" mainType, main) : Map.toList defs
        genGlobDefs = withGlobDefSigs
        genGlobDefs = withExternSigs externs $ withGlobDefSigs
            defs'
            (liftA2 (:) genOuterMain (fmap join (mapM genGlobDef defs')))
    globDefs <- runGen' genGlobDefs


@@ 116,7 115,8 @@ codegen moduleFilePath (Program main (Defs defs) tdefs) = do
        , moduleSourceFileName = fromString moduleFilePath
        , moduleDataLayout = Just cfg_dataLayout
        , moduleTargetTriple = Nothing
        , moduleDefinitions = tdefs' ++ genBuiltins ++ globDefs
        , moduleDefinitions =
            tdefs' ++ genBuiltins ++ genExterns externs ++ globDefs
        }

-- TODO: Consider separating sizeof calculations to a separate pass preceeding


@@ 152,9 152,7 @@ defineDataTypes tds = do
        pure (TypeDefinition n (Just tmax))

runGen' :: Gen' a -> EncodeAST a
runGen' g = runReaderT
    (evalStateT g initSt)
    Env { _localEnv = Map.empty, _globalEnv = Map.empty }
runGen' g = runReaderT (evalStateT g initSt) Env { _env = Map.empty }

initSt :: St
initSt = St


@@ 170,9 168,29 @@ genBuiltins = map
        (mkName "malloc")
        [parameter (mkName "size") i64]
        (LLType.ptr typeUnit)
    , simpleFunc (mkName "print-int") [parameter (mkName "n") i64] typeUnit
    ]

genExterns :: [(String, MonoAst.Type)] -> [Definition]
genExterns = map (uncurry genExtern)

genExtern :: String -> MonoAst.Type -> Definition
genExtern name t = GlobalDefinition $ GlobalVariable
    { LLGlob.name = mkName name
    , LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Default
    , LLGlob.dllStorageClass = Nothing
    , LLGlob.threadLocalMode = Nothing
    , LLGlob.unnamedAddr = Nothing
    , LLGlob.isConstant = True
    , LLGlob.type' = toLlvmType t
    , LLGlob.addrSpace = LLAddr.AddrSpace 0
    , LLGlob.initializer = Nothing
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0
    , LLGlob.metadata = []
    }

genOuterMain :: Gen' Definition
genOuterMain = do
    assign currentBlockLabel (mkName "entry")


@@ 289,22 307,15 @@ genConst = \case

lookupVar :: TypedVar -> Gen Operand
lookupVar x = do
    mayLocal <- views localEnv (Map.lookup x)
    mayGlobPtr <- views globalEnv (Map.lookup x)
    case (mayLocal, mayGlobPtr) of
        (Just local, _) -> emitAnon $ load local
        (Nothing, Just globPtr) -> emitAnon $ load globPtr
        (Nothing, Nothing) -> ice $ "Undefined variable " ++ show x
    views env (Map.lookup x) >>= \case
        Just var -> emitAnon $ load var
        Nothing -> ice $ "Undefined variable " ++ show x

genApp :: Expr -> Expr -> Gen Operand
genApp fe ae = do
    a <- genExpr ae
    case fe of
        Var (TypedVar "print-int" _) ->
            emitAnon (callExtern "print-int" typeUnit [a])
        _ -> do
            closure <- genExpr fe
            app closure a
    closure <- genExpr fe
    app closure a

app :: Operand -> Operand -> Gen Operand
app closure arg = do


@@ 522,8 533,17 @@ parameter p pt = LLGlob.Parameter pt p []
genSizeof :: Type -> Gen Operand
genSizeof = fmap litU64' . lift . lift . lift . sizeof

withExternSigs :: MonadReader Env m => [(String, MonoAst.Type)] -> m a -> m a
withExternSigs = augment env . Map.fromList . map
    (\(name, t) ->
        ( TypedVar name t
        , ConstantOperand
            (LLConst.GlobalReference (LLType.ptr (toLlvmType t)) (mkName name))
        )
    )

withGlobDefSigs :: MonadReader Env m => [(TypedVar, Expr)] -> m a -> m a
withGlobDefSigs = augment globalEnv . Map.fromList . map
withGlobDefSigs = augment env . Map.fromList . map
    (\(v@(TypedVar _ t), _) ->
        ( v
        , ConstantOperand


@@ 532,7 552,7 @@ withGlobDefSigs = augment globalEnv . Map.fromList . map
    )

withDefSigs :: [(TypedVar, Name)] -> Gen a -> Gen a
withDefSigs = augment localEnv . Map.fromList . map
withDefSigs = augment env . Map.fromList . map
    (\(v@(TypedVar _ t), n') ->
        (v, LocalReference (LLType.ptr (toLlvmType t)) n')
    )


@@ 550,7 570,7 @@ withLocal x v gen = do
-- | Takes a local value, allocates a variable for it, and runs a generator in
--   the environment with the variable
withVar :: TypedVar -> Operand -> Gen a -> Gen a
withVar x v = locally localEnv (Map.insert x v)
withVar x v = locally env (Map.insert x v)

genVar :: Name -> Type -> Gen Operand -> Gen Operand
genVar n t gen = do

M src/Compile.hs => src/Compile.hs +1 -1
@@ 48,7 48,7 @@ compileModule cfg m = withHostTargetMachinePIC $ \t -> do
        [ "-o"
        , binfile
        , ofile
        , "/home/jojo/Hack/carth/foreign-core/libcarth_foreign_core.a"
        , "/home/jojo/Hack/carth/foreign-core/target/debug/libcarth_foreign_core.a"
        , "-ldl"
        , "-lpthread"
        ]

M src/Mono.hs => src/Mono.hs +7 -4
@@ 37,13 37,16 @@ makeLenses ''Insts
type Mono = StateT Insts (Reader Env)

monomorphize :: An.Program -> Program
monomorphize (An.Program main defs tdefs) =
monomorphize (An.Program main defs tdefs externs) =
    let
        initInsts = Insts Map.empty Set.empty
        ((defs', main'), Insts _ tdefInsts') =
            runReader (runStateT (monoLet defs main) initInsts) initEnv
        run m = runReader (runStateT m initInsts) initEnv
        ((externs', (defs', main')), Insts _ tdefInsts') = run $ liftA2
            (,)
            (mapM (bimapM pure monotype) (Map.toList externs))
            (monoLet defs main)
        tdefs' = instTypeDefs tdefs tdefInsts'
    in Program main' defs' tdefs'
    in Program main' defs' tdefs' externs'

initEnv :: Env
initEnv = Env { _defs = Map.empty, _tvBinds = Map.empty }

M src/MonoAst.hs => src/MonoAst.hs +3 -1
@@ 74,7 74,9 @@ newtype Defs = Defs (Map TypedVar Expr)

type TypeDefs = [(TConst, [VariantTypes])]

data Program = Program Expr Defs TypeDefs
type Externs = [(String, Type)]

data Program = Program Expr Defs TypeDefs Externs
    deriving (Show)



M src/Parse.hs => src/Parse.hs +15 -7
@@ 15,7 15,7 @@ module Parse
    , reserveds
    , ns_scheme
    , ns_pat
    , var
    , ns_small'
    , eConstructor
    , ns_expr
    , ns_big


@@ 60,18 60,25 @@ parse' p name src = mapLeft errorBundlePretty (Mega.parse p name src)
program :: Parser Program
program = do
    space
    (defs, typedefs) <- toplevels
    (defs, typedefs, externs) <- toplevels
    eof
    pure (Program defs typedefs)
    pure (Program defs typedefs externs)

toplevels :: Parser ([Def], [TypeDef])
toplevels = option ([], []) (toplevel >>= flip fmap toplevels)
toplevels :: Parser ([Def], [TypeDef], [Extern])
toplevels = option ([], [], []) (toplevel >>= flip fmap toplevels)

toplevel :: Parser (([Def], [TypeDef]) -> ([Def], [TypeDef]))
toplevel
    :: Parser (([Def], [TypeDef], [Extern]) -> ([Def], [TypeDef], [Extern]))
toplevel = do
    topPos <- getSrcPos
    parens $ choice
        [fmap (second . (:)) typedef, fmap (first . (:)) (def topPos)]
        [ fmap (\a (as, bs, cs) -> (a : as, bs, cs)) (def topPos)
        , fmap (\b (as, bs, cs) -> (as, b : bs, cs)) typedef
        , fmap (\c (as, bs, cs) -> (as, bs, c : cs)) extern
        ]

extern :: Parser Extern
extern = reserved "extern" *> liftA2 Extern small' type_

typedef :: Parser TypeDef
typedef = do


@@ 348,6 355,7 @@ reserveds =
    , "Fun"
    , "define"
    , "define:"
    , "extern"
    , "forall"
    , "unit"
    , "true"

M src/Subst.hs => src/Subst.hs +2 -2
@@ 14,8 14,8 @@ import AnnotAst
type Subst = Map TVar Type

substProgram :: Subst -> Program -> Program
substProgram s (Program main (Defs defs) tdefs) =
    Program (substExpr s main) (Defs (fmap (substDef s) defs)) tdefs
substProgram s (Program main (Defs defs) tdefs externs) =
    Program (substExpr s main) (Defs (fmap (substDef s) defs)) tdefs externs

substDef :: Subst -> (Scheme, Expr) -> (Scheme, Expr)
substDef s = second (substExpr s)

M src/TypeErr.hs => src/TypeErr.hs +9 -1
@@ 25,6 25,7 @@ data TypeErr
    | ConflictingCtorDef (Id Big)
    | RedundantCase SrcPos
    | InexhaustivePats SrcPos String
    | ExternNotMonomorphic (Id Small) TVar
    deriving Show

type Message = String


@@ 70,6 71,12 @@ prettyErr = \case
            $ "Inexhaustive patterns: "
            ++ patStr
            ++ " not covered."
    ExternNotMonomorphic name tv -> case tv of
        TVExplicit (Id (WithPos p tv')) ->
            posd p tvar
                $ ("Extern " ++ pretty name ++ " is not monomorphic. ")
                ++ ("Type variable " ++ tv' ++ " encountered in type signature")
        TVImplicit _ -> ice "TVImplicit in prettyErr ExternNotMonomorphic"
  where
    -- | Used to handle that the position of the generated nested lambdas of a
    --   definition of the form `(define (foo a b ...) ...)` is set to the


@@ 80,7 87,8 @@ prettyErr = \case
            <||> wholeLine
    scheme = Parse.ns_scheme <||> wholeLine
    pat = Parse.ns_pat <||> wholeLine
    var = Parse.var <||> wholeLine
    var = Parse.ns_small' <||> wholeLine
    tvar = var
    eConstructor = Parse.eConstructor <||> wholeLine
    big = Parse.ns_big
    wholeLine = many Mega.anySingle