~jojo/Carth

97882a5a220b7eae29dd899757770a141529031d — JoJo 1 year, 4 months ago 360e103
Add global variables

Previously, top-level definitions could only be functions. Now,
non-function variables are initialized with `carth_init` in `main`.

Could be interesting to initialize them at compile time instead, using
some kind of compile-time evaluation mechanism, probably using the JIT.
M examples/fizzbuzz.carth => examples/fizzbuzz.carth +2 -2
@@ 1,8 1,8 @@
(import std)

(define (main Unit) (fizzbuzz Unit))
(define main fizzbuzz)

(define (fizzbuzz _)
(define (fizzbuzz Unit)
  (for (range 1 100)
       (<o display fizzbuzz')))


M examples/hello-world.carth => examples/hello-world.carth +0 -1
@@ 1,5 1,4 @@
(import std)


(define (main unit)
  (display (str-append "Hello, world!" "\n")))

M src/Codegen.hs => src/Codegen.hs +52 -24
@@ 48,6 48,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
                (enums, tdefs'') =
                    runIdentity (runGen' (defineDataTypes tdefs))
                defs' = defToVarDefs =<< defs
                (funDefs, varDefs) = separateFunDefs defs'
            in
                runGen'
                $ augment enumTypes enums


@@ 57,7 58,11 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
                $ withGlobDefSigs (map (second unpos) defs')
                $ do
                    es <- genExterns externs
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs'))
                    funDefs' <- mapM genGlobFunDef funDefs
                    varDecls <- mapM genGlobVarDecl varDefs
                    init_ <- genInit varDefs
                    main <- genMain
                    let ds = main : init_ : join funDefs' ++ varDecls
                    pure (tdefs'', es, ds)
        pure $ Module
            { moduleName = fromString ((takeBaseName moduleFilePath))


@@ 168,38 173,61 @@ defineDataTypes tds = do

genMain :: Gen' Definition
genMain = do
    let init_ = ConstantOperand $ LLConst.GlobalReference
            (LLType.ptr (FunctionType LLType.void [] False))
            (mkName "carth_init")
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ _ <- execWriterT $ do
        emitDo' =<< callBuiltin "install_stackoverflow_handler" []
        emitDo (callExtern init_ [])
        f <- lookupVar (TypedVar "main" mainType)
        _ <- app Nothing f (VLocal litUnit)
        commitFinalFuncBlock (ret (litI32 0))
    pure (GlobalDefinition (externFunc (mkName "main") [] i32 basicBlocks []))

-- TODO: Change global defs to a new type that can be generated by llvm. As it
--       is now, global non-function variables can't be straight-forwardly
--       generated in general. Either, initialization is delayed until program
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef :: (TypedVar, WithPos ([M.Type], Expr')) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, e)) = case e of
    Fun (p, (body, rt)) -> do
        let var = (v, ts)
        let name = mangleName var
        assign lambdaParentFunc (Just name)
        assign outerLambdaN 1
        let fName = mkName (name ++ "_func")
        (f, gs) <- genFunDef
            (fName, [], dpos, p, genTailExpr body *> genRetType rt)
        let fRef = LLConst.GlobalReference (LLType.ptr (typeOf f)) fName
        let capturesType = LLType.ptr typeUnit
        let captures = LLConst.Null capturesType
        let closure = litStruct [captures, fRef]
        let closureDef = simpleGlobVar (mkName name) (typeOf closure) closure
        pure (GlobalDefinition closureDef : GlobalDefinition f : gs)
    _ -> nyi $ "Global non-function defs: " ++ show e
separateFunDefs :: [VarDef] -> ([FunDef], [VarDef])
separateFunDefs = partitionWith $ \(lhs, WithPos dpos (ts, e)) -> case e of
    Fun f -> Left (lhs, WithPos dpos (ts, f))
    _ -> Right (lhs, WithPos dpos (ts, e))

genInit :: [VarDef] -> Gen' Definition
genInit ds = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ _ <- execWriterT $ do
        forM_ ds genDefineGlobVar
        commitFinalFuncBlock retVoid
    pure $ GlobalDefinition
        (externFunc (mkName "carth_init") [] LLType.void basicBlocks [])

genDefineGlobVar :: VarDef -> Gen ()
genDefineGlobVar (TypedVar v _, WithPos pos (ts, e)) = do
    let name = mkName (mangleName (v, ts))
    e' <- getLocal =<< genExpr (Expr (Just pos) e)
    let ref = LLConst.GlobalReference (LLType.ptr (typeOf e')) name
    emitDo (store e' (ConstantOperand ref))

genGlobVarDecl :: VarDef -> Gen' Definition
genGlobVarDecl (TypedVar v t, WithPos _ (ts, _)) = do
    let name = mkName (mangleName (v, ts))
    t' <- genType' t
    pure (GlobalDefinition (simpleGlobVar name t' (LLConst.Undef t')))

genGlobFunDef :: FunDef -> Gen' [Definition]
genGlobFunDef (TypedVar v _, WithPos dpos (ts, (p, (body, rt)))) = do
    let var = (v, ts)
    let name = mangleName var
    assign lambdaParentFunc (Just name)
    assign outerLambdaN 1
    let fName = mkName (name ++ "_func")
    (f, gs) <- genFunDef (fName, [], dpos, p, genTailExpr body *> genRetType rt)
    let fRef = LLConst.GlobalReference (LLType.ptr (typeOf f)) fName
    let capturesType = LLType.ptr typeUnit
    let captures = LLConst.Null capturesType
    let closure = litStruct [captures, fRef]
    let closureDef = simpleGlobConst (mkName name) (typeOf closure) closure
    pure (GlobalDefinition closureDef : GlobalDefinition f : gs)

genTailExpr :: Expr -> Gen ()
genTailExpr (Expr pos expr) = locally srcPos (pos <|>) $ do

M src/Extern.hs => src/Extern.hs +1 -1
@@ 130,7 130,7 @@ genWrapper pos externName rt paramTs =
            let fref = LLConst.GlobalReference (LLType.ptr (typeOf f)) fname
            let captures = LLConst.Null (LLType.ptr typeUnit)
            let closure = litStruct [captures, fref]
            let closureDef = simpleGlobVar
            let closureDef = simpleGlobConst
                    (mkName ("_wrapper_" ++ externName))
                    (typeOf closure)
                    closure

M src/Gen.hs => src/Gen.hs +9 -6
@@ 153,7 153,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
        let bytes = UTF8.String.encode s
            len = length bytes
            tInner = ArrayType (fromIntegral len) i8
            defInner = simpleGlobVar
            defInner = simpleGlobConst
                name_inner
                tInner
                (LLConst.Array i8 (map litI8' bytes))


@@ 163,7 163,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                ("Array", [M.TPrim TNat8])
                [ptrBytes, litI64' len]
            str = litStructNamed ("Str", []) [array]
            defStr = simpleGlobVar strName typeStr str
            defStr = simpleGlobConst strName typeStr str
        pure (map GlobalDefinition [defInner, defStr])
    genExtractCaptures = do
        capturesName <- newName "captures"


@@ 368,10 368,13 @@ externFunc n ps rt bs meta = Function
    }

simpleGlobVar :: Name -> Type -> LLConst.Constant -> Global
simpleGlobVar name t = simpleGlobVar' name t . Just
simpleGlobVar name t = simpleGlobVar' False name t . Just

simpleGlobVar' :: Name -> Type -> Maybe LLConst.Constant -> Global
simpleGlobVar' name t initializer = GlobalVariable
simpleGlobConst :: Name -> Type -> LLConst.Constant -> Global
simpleGlobConst name t = simpleGlobVar' True name t . Just

simpleGlobVar' :: Bool -> Name -> Type -> Maybe LLConst.Constant -> Global
simpleGlobVar' isconst name t initializer = GlobalVariable
    { LLGlob.name = name
    , LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Default


@@ 379,7 382,7 @@ simpleGlobVar' name t initializer = GlobalVariable
    , LLGlob.threadLocalMode = Nothing
    , LLGlob.addrSpace = LLAddr.AddrSpace 0
    , LLGlob.unnamedAddr = Nothing
    , LLGlob.isConstant = True
    , LLGlob.isConstant = isconst
    , LLGlob.type' = t
    , LLGlob.initializer = initializer
    , LLGlob.section = Nothing

M src/Misc.hs => src/Misc.hs +9 -0
@@ 6,6 6,7 @@ import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Data.Foldable
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State


@@ 88,3 89,11 @@ splitOn sep = fromMaybe [] . Mega.parseMaybe splitOn'
        as <- many (try (manyTill anySingle (try (string sep))))
        a <- many anySingle
        pure $ (as ++) $ if not (null a) then [a] else []

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith f = foldl'
    (\(bs, cs) x -> case f x of
        Left b -> (b : bs, cs)
        Right c -> (bs, c : cs)
    )
    ([], [])

M src/Monomorphic.hs => src/Monomorphic.hs +2 -1
@@ 79,7 79,8 @@ data Expr = Expr (Maybe SrcPos) Expr'
type Defs = TopologicalOrder Def
data Def = VarDef VarDef | RecDefs RecDefs deriving Show
type VarDef = (TypedVar, WithPos ([Type], Expr'))
type RecDefs = [(TypedVar, WithPos ([Type], Fun))]
type RecDefs = [FunDef]
type FunDef = (TypedVar, WithPos ([Type], Fun))
type TypeDefs = [(TConst, [VariantTypes])]
type Externs = [(String, Type, SrcPos)]


M std/iter.carth => std/iter.carth +1 -1
@@ 6,7 6,7 @@
  (Iter (Fun Unit (Maybe (Pair a (Iter a))))))

(define (next (Iter it)) (it Unit))
(define (next! it) (unwrap! (next it)))
(define next! (<o unwrap! next))

(define (xrange a b) (take (-i b a)       (range-from a)))
(define (range  a b) (take (inc (-i b a)) (range-from a)))

M std/math.carth => std/math.carth +7 -0
@@ 1,3 1,10 @@
(define: pi F64 3.14159265358979323846264338327950288)
(define: inv-pi F64 0.318309886183790671537767526745028724)

(extern sin (Fun F64 F64))
(extern cos (Fun F64 F64))
(extern tan (Fun F64 F64))

(define (inc n) (+i n 1))
(define (dec n) (-i n 1))