~jojo/Carth

8c7156e4e654ef83cd383643066dc6ab979f44ea — JoJo 1 year, 10 months ago 6ba3090
Rename main to start & fix start-related stuff

First, the reason for the rename. Having both an "outer" and an
"inner" main named main (with LLVM kindly generating some suffix to
separate them) was just not very pretty looking. Another problem was
that, while not possible before, e.g. recursing in main would not
work, as the main found would not be the inner main, but the outer
main. Renaming the inner (user defined) main to start alleviates this
issue.

Another approach we could've taken is to rename the outer main, and
tell the linker (via GCC/Clang) that we have another entrypoint than
main. I started working on this, but just appending a "-e outer_main"
flag was no good. The problem was that the entrypoint changed was not
main to outer_main, but rather _start to outer_main. This was no good,
as _start usually sets up some things before calling main, and the
result was segfaults.

Also, now start (main) is treated more like any other global def, and
you can call main from other functions and recurse etc. I had to fix
how main is typechecked a bit for this to work correctly.
M examples/fizzbuzz.carth => examples/fizzbuzz.carth +1 -1
@@ 5,7 5,7 @@
  Nil
  (Cons a (Box (List a))))

(define (main _)
(define (start _)
  (for (Cons "foo" (box (Cons "bar" (box (Cons "baz" (box Nil))))))
       display
       unit))

M examples/hello-world.carth => examples/hello-world.carth +1 -1
@@ 1,7 1,7 @@
(type (Pair a b)
  (Pair a b))

(define (main _)
(define (start _)
  (display "Hello, world!"))



M src/AnnotAst.hs => src/AnnotAst.hs +3 -1
@@ 20,13 20,15 @@ module AnnotAst
    , TypeDefs
    , Ctors
    , Externs
    , startType
    )
where

import Data.Map.Strict (Map)
import Data.Word

import Ast (TVar(..), TPrim(..), TConst, Type(..), Scheme(..), Const(..))
import Ast
    (TVar(..), TPrim(..), TConst, Type(..), Scheme(..), Const(..), startType)
import SrcPos



M src/Ast.hs => src/Ast.hs +4 -0
@@ 22,6 22,7 @@ module Ast
    , TypeDef(..)
    , Extern(..)
    , Program(..)
    , startType
    )
where



@@ 356,3 357,6 @@ spcPretty = unwords . map pretty

idstr :: Id a -> String
idstr (Id (WithPos _ x)) = x

startType :: Type
startType = TFun (TPrim TUnit) (TPrim TUnit)

M src/Check.hs => src/Check.hs +3 -5
@@ 34,7 34,7 @@ typecheck (Ast.Program defs tdefs externs) = runExcept $ do
    checkTypeVarsBound substd
    let desugared = unsugar substd
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (uncurry Des.Program desugared tdefs'' externs')
    pure (Des.Program desugared tdefs'' externs')

checkTypeDefs :: [Ast.TypeDef] -> Except TypeErr (An.TypeDefs, An.Ctors)
checkTypeDefs tdefs = do


@@ 139,10 139,8 @@ type Bound = ReaderT (Set TVar) (Except TypeErr) ()

-- TODO: Many of these positions are weird and kind of arbitrary, man. They may
--       not align with where the type variable is actually detected.
checkTypeVarsBound :: (An.Expr, An.Defs) -> Except TypeErr ()
checkTypeVarsBound (main, ds) = runReaderT
    (boundInExpr main >> boundInDefs ds)
    Set.empty
checkTypeVarsBound :: An.Defs -> Except TypeErr ()
checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
  where
    boundInDefs :: An.Defs -> Bound
    boundInDefs = mapM_ boundInDef

M src/Codegen.hs => src/Codegen.hs +6 -6
@@ 140,12 140,12 @@ instance Typed Val where


codegen :: DataLayout -> FilePath -> Program -> EncodeAST Module
codegen layout moduleFilePath (Program main defs tdefs externs) = do
codegen layout moduleFilePath (Program defs tdefs externs) = do
    tdefs' <- defineDataTypes layout tdefs
    let defs' = (TypedVar "-main" mainType, ([], main)) : Map.toList defs
    let defs' = Map.toList defs
        genGlobDefs = withExternSigs externs $ withGlobDefSigs
            defs'
            (liftA2 (:) genOuterMain (fmap join (mapM genGlobDef defs')))
            (liftA2 (:) genMain (fmap join (mapM genGlobDef defs')))
    globDefs <- runGen' layout genGlobDefs
    pure Module
        { moduleName = fromString ((takeBaseName moduleFilePath))


@@ 218,12 218,12 @@ genExtern :: String -> MonoAst.Type -> Definition
genExtern name t =
    GlobalDefinition $ simpleGlobVar' (mkName name) (toLlvmType t) Nothing

genOuterMain :: Gen' Definition
genOuterMain = do
genMain :: Gen' Definition
genMain = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ <- execWriterT $ do
        f <- lookupVar (TypedVar "-main" mainType)
        f <- lookupVar (TypedVar "start" startType)
        _ <- app f (VLocal (ConstantOperand litUnit)) typeUnit
        commitFinalFuncBlock (ret (ConstantOperand (litI32 0)))
    pure (GlobalDefinition (simpleFunc (mkName "main") [] i32 basicBlocks))

M src/Desugar.hs => src/Desugar.hs +2 -2
@@ 9,8 9,8 @@ import SrcPos
import qualified AnnotAst as An
import DesugaredAst

unsugar :: (An.Expr, An.Defs) -> (Expr, Defs)
unsugar (main, ds) = (unsugarExpr main, unsugarDefs ds)
unsugar :: An.Defs -> Defs
unsugar = unsugarDefs

unsugarDefs :: An.Defs -> Defs
unsugarDefs = fmap (second unsugarExpr)

M src/DesugaredAst.hs => src/DesugaredAst.hs +3 -1
@@ 15,6 15,7 @@ module DesugaredAst
    , TypeDefs
    , Externs
    , Program(..)
    , startType
    )
where



@@ 29,6 30,7 @@ import AnnotAst
    , Const(..)
    , VariantIx
    , Access(..)
    , startType
    )

data TypedVar = TypedVar String Type


@@ 58,5 60,5 @@ type Defs = Map String (Scheme, Expr)
type TypeDefs = Map String ([TVar], [[Type]])
type Externs = Map String Type

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

M src/Infer.hs => src/Infer.hs +14 -11
@@ 57,7 57,7 @@ inferTopDefs
    -> Ctors
    -> [Ast.Extern]
    -> [Ast.Def]
    -> Except TypeErr (Externs, (Expr, Defs), Subst)
    -> Except TypeErr (Externs, Defs, Subst)
inferTopDefs tdefs ctors externs defs = evalStateT
    (runReaderT inferTopDefs' initEnv)
    initSt


@@ 65,17 65,20 @@ inferTopDefs tdefs ctors externs defs = evalStateT
    inferTopDefs' = augment envTypeDefs tdefs $ augment envCtors ctors $ do
        externs' <- checkExterns externs
        let externs'' = fmap (Forall Set.empty) externs'
        defs' <- augment envDefs externs'' (inferDefs defs)
        (_, (WithPos mainPos _)) <- maybe
            (throwError MainNotDefined)
            pure
            (lookup "main" (map (first idstr) defs))
        let (Forall _ mainT, main) = defs' Map.! "main"
        let expectedMainType = TFun (TPrim TUnit) (TPrim TUnit)
        unify (Expected expectedMainType) (Found mainPos mainT)
        let defs'' = Map.delete "main" defs'
        defs' <- checkStartType defs
        defs'' <- augment envDefs externs'' (inferDefs defs')
        s <- use substs
        pure (externs', (main, defs''), s)
        pure (externs', defs'', s)
    checkStartType :: [Ast.Def] -> Infer [Ast.Def]
    checkStartType = \case
        (x@(Id (WithPos _ "start")), (s, b)) : ds ->
            if s == Nothing || unpos (fromJust s) == startScheme
                then pure
                    ((x, (Just (WithPos dummyPos startScheme), b)) : ds)
                else throwError (WrongStartType (fromJust s))
        d : ds -> fmap (d :) (checkStartType ds)
        [] -> throwError StartNotDefined
    startScheme = Forall Set.empty startType
    initEnv = Env
        { _envDefs = Map.empty
        , _envCtors = Map.empty

M src/Mono.hs => src/Mono.hs +3 -3
@@ 39,11 39,11 @@ makeLenses ''Insts
type Mono = StateT Insts (Reader Env)

monomorphize :: An.Program -> Program
monomorphize (An.Program main defs tdefs externs) = evalMono $ do
monomorphize (An.Program defs tdefs externs) = evalMono $ do
    externs' <- mapM (bimapM pure monotype) (Map.toList externs)
    (defs', main') <- monoLet defs main
    (defs', _) <- monoLet defs (An.Var (An.TypedVar "start" An.startType))
    tdefs' <- instTypeDefs tdefs
    pure (Program main' defs' tdefs' externs')
    pure (Program defs' tdefs' externs')

evalMono :: Mono a -> a
evalMono ma = runReader (evalStateT ma initInsts) initEnv

M src/MonoAst.hs => src/MonoAst.hs +4 -4
@@ 19,7 19,7 @@ module MonoAst
    , Defs
    , TypeDefs
    , Program(..)
    , mainType
    , startType
    )
where



@@ 76,7 76,7 @@ type Defs = Map TypedVar ([Type], Expr)
type TypeDefs = [(TConst, [VariantTypes])]
type Externs = [(String, Type)]

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




@@ 103,5 103,5 @@ fvDecisionTree = \case
        Set.unions $ fvDecisionTree def : map fvDecisionTree (Map.elems cs)
    DLeaf (bs, e) -> Set.difference (fvExpr e) (Set.fromList (map fst bs))

mainType :: Type
mainType = TFun (TPrim TUnit) (TPrim TUnit)
startType :: Type
startType = TFun (TPrim TUnit) (TPrim TUnit)

M src/Subst.hs => src/Subst.hs +2 -2
@@ 13,8 13,8 @@ import AnnotAst
-- | Map of substitutions from type-variables to more specific types
type Subst = Map TVar Type

substTopDefs :: Subst -> (Expr, Defs) -> (Expr, Defs)
substTopDefs s (main, defs) = (substExpr s main, fmap (substDef s) defs)
substTopDefs :: Subst -> Defs -> Defs
substTopDefs s defs = fmap (substDef s) defs

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

M src/TypeErr.hs => src/TypeErr.hs +8 -2
@@ 13,7 13,7 @@ import Data.Functor
import Control.Applicative

data TypeErr
    = MainNotDefined
    = StartNotDefined
    | InvalidUserTypeSig SrcPos Scheme Scheme
    | CtorArityMismatch SrcPos (Id Big) Int Int
    | ConflictingPatVarDefs SrcPos String


@@ 30,13 30,14 @@ data TypeErr
    | RecTypeDef String SrcPos
    | UndefType SrcPos String
    | UnboundTVar SrcPos
    | WrongStartType (WithPos Scheme)
    deriving Show

type Message = String

prettyErr :: TypeErr -> Parse.Source -> String
prettyErr = \case
    MainNotDefined -> const "Error: main not defined"
    StartNotDefined -> const "Error: start not defined"
    InvalidUserTypeSig p s1 s2 ->
        posd p scheme
            $ ("Invalid user type signature " ++ pretty s1)


@@ 92,6 93,11 @@ prettyErr = \case
        posd p defOrExpr
            $ "Could not fully infer type of expression.\n"
            ++ "Type annotations needed."
    WrongStartType (WithPos p s) ->
        posd p scheme
            $ "Incorrect type of `start`.\n"
            ++ ("Expected: " ++ pretty startType)
            ++ ("\nFound: " ++ pretty s)
  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