~jojo/Carth

eacedc384a69f8fcea695502b2c7f06776e212ee — JoJo 21 days ago f5e09e9
Duplicate AST defs from Monomorphic to Low

Also had to add a bunch of basically no-op translation in Lower.hs
just to fix the types. Atm it's pointless, but it will serve as a base
to work on as the Low AST drifts from the Monomorphic AST.
10 files changed, 236 insertions(+), 18 deletions(-)

M TODO.org
M carth.cabal
M src/Codegen.hs
M src/Gen.hs
M src/Infer.hs
M src/Low.hs
M src/Lower.hs
M src/Misc.hs
M src/Monomorphic.hs
M src/SrcPos.hs
M TODO.org => TODO.org +13 -0
@@ 661,6 661,8 @@ Features and other stuff to do/implement in/around Carth.

  Polysemy seems like the best one, but I'd have to do a little
  research. https://github.com/thma/PolysemyCleanArchitecture/tree/3a9354a5c31eaf03009e389ce49b318881a2460f#readme

  https://koka-lang.github.io/koka/doc/index.html
* INACTIVE GRIN as alternative to LLVM and some of my own Codegen
  https://github.com/grin-compiler/grin



@@ 1039,3 1041,14 @@ Features and other stuff to do/implement in/around Carth.
** References
   - [[https://gist.github.com/zeux/3ce4fcc3a43072b4315abde95319ecb6][How does clang 2.7 hold up in 2021?]]
* NEXT Try our an alternative prelude, like relude
* TODO `tail` keyword to ensure tail call or compiler error
  Sometimes you want to be sure that tail calls are optimized. To be
  able to assert this at compile time, so as to not accidentally
  create a stack consuming function when it really matters, add a
  `tail` keyword.

  TCO should already performed as an optimization, but with `tail`,
  you can ensure that you get a compiler error if the call is not
  actually a tail call, if you've done something wrong or
  something. Sort of like Rust is considering the `become` keyword to
  work?

M carth.cabal => carth.cabal +0 -3
@@ 77,7 77,6 @@ library
    , FlexibleContexts
    , FlexibleInstances
    , OverloadedStrings
    , RankNTypes
    , MultiParamTypeClasses
    , TypeSynonymInstances
    , KindSignatures


@@ 107,7 106,6 @@ executable carth
    , FlexibleContexts
    , FlexibleInstances
    , OverloadedStrings
    , RankNTypes
    , MultiParamTypeClasses
    , TypeSynonymInstances
    , KindSignatures


@@ 138,7 136,6 @@ test-suite carth-test
    , FlexibleContexts
    , FlexibleInstances
    , OverloadedStrings
    , RankNTypes
    , MultiParamTypeClasses
    , TypeSynonymInstances
    , KindSignatures

M src/Codegen.hs => src/Codegen.hs +1 -1
@@ 1,4 1,4 @@
{-# LANGUAGE DuplicateRecordFields, GADTs #-}
{-# LANGUAGE DuplicateRecordFields, GADTs, RankNTypes #-}

-- | Generation of LLVM IR code from our monomorphic AST.
module Codegen (codegen) where

M src/Gen.hs => src/Gen.hs +2 -2
@@ 44,8 44,8 @@ import Misc
import Pretty
import qualified TypeAst
import qualified Low as Ast
import qualified Lower as Ast
import Low (TypedVar(..), TPrim(..))
import qualified Monomorphize
import SrcPos




@@ 742,7 742,7 @@ call callconv tailkind f as meta = Call { tailCallKind = tailkind
withBuiltins :: Gen' a -> Gen' a
withBuiltins ga = builtinExterns
    >>= \es -> augment builtins (Map.union builtinsHidden es) ga
    where builtinExterns = mapM (fmap snd . genExternTypeSig) Monomorphize.builtinExterns
    where builtinExterns = mapM (fmap snd . genExternTypeSig) Ast.builtinExterns

defineBuiltinsHidden :: [Definition]
defineBuiltinsHidden = map

M src/Infer.hs => src/Infer.hs +1 -1
@@ 1,4 1,4 @@
{-# LANGUAGE TemplateHaskell, DataKinds #-}
{-# LANGUAGE TemplateHaskell, DataKinds, RankNTypes #-}

module Infer (inferTopDefs, checkType', checkType'') where


M src/Low.hs => src/Low.hs +118 -2
@@ 1,3 1,119 @@
module Low (module Monomorphic) where
{-# LANGUAGE TemplateHaskell #-}

import Monomorphic
module Low (module Low, TPrim(..), Const(..), VariantIx, Span, tUnit, Access' (..)) where

import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Bifunctor

import Misc
import SrcPos
import Checked (VariantIx, Span)
import FreeVars
import Parsed (Const(..))
import TypeAst hiding (TConst)
import qualified TypeAst
import Monomorphic (Access'(..))

type TConst = TypeAst.TConst Type

data Type
    = TPrim TPrim
    | TFun Type Type
    | TBox Type
    | TConst TConst
    deriving (Show, Eq, Ord)

data TypedVar = TypedVar String Type
    deriving (Show, Eq, Ord)

type Access = Access' Type

type VariantTypes = [Type]

type VarBindings = [(TypedVar, Access)]

data DecisionTree
    = DLeaf (VarBindings, Expr)
    | DSwitch Access (Map VariantIx DecisionTree) DecisionTree
    | DSwitchStr Access (Map String DecisionTree) DecisionTree
    deriving Show

type Ction = (VariantIx, Span, TConst, [Expr])
type Fun = (TypedVar, (Expr, Type))

data Expr'
    = Lit Const
    | Var TypedVar
    | App Expr Expr Type
    | If Expr Expr Expr
    | Fun Fun
    | Let Def Expr
    | Match Expr DecisionTree Type
    | Ction Ction
    | Sizeof Type
    | Absurd Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'
    deriving Show

type Defs = TopologicalOrder Def
data Def = VarDef VarDef | RecDefs RecDefs deriving Show
type VarDef = (TypedVar, WithPos ([Type], Expr'))
type RecDefs = [FunDef]
type FunDef = (TypedVar, WithPos ([Type], Fun))
type Datas = Map TConst [VariantTypes]
type Externs = [(String, Type, SrcPos)]

data Program = Program Defs Datas Externs
    deriving Show

instance TypeAst Type where
    tprim = TPrim
    tconst = TConst
    tfun = TFun
    tbox = TBox

instance FreeVars Expr TypedVar where
    freeVars (Expr _ e) = fvExpr' e

instance FreeVars Expr' TypedVar where
    freeVars = fvExpr'

expr' :: Expr -> Expr'
expr' (Expr _ e) = e

fvExpr' :: Expr' -> Set TypedVar
fvExpr' = \case
    Lit _ -> Set.empty
    Var x -> Set.singleton x
    App f a _ -> fvApp f a
    If p c a -> fvIf p c a
    Fun (p, (b, _)) -> fvFun p b
    Let (VarDef (lhs, WithPos _ (_, rhs))) (Expr _ e) ->
        Set.union (freeVars rhs) (Set.delete lhs (freeVars e))
    Let (RecDefs ds) (Expr _ e) -> fvLet (unzip (map (second (Fun . snd . unpos)) ds)) e
    Match e dt _ -> Set.union (freeVars e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map freeVars as)
    Sizeof _t -> Set.empty
    Absurd _ -> Set.empty

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case
    DLeaf (bs, e) -> Set.difference (freeVars e) (Set.fromList (map fst bs))
    DSwitch _ cs def -> fvDSwitch (Map.elems cs) def
    DSwitchStr _ cs def -> fvDSwitch (Map.elems cs) def
    where fvDSwitch es def = Set.unions $ fvDecisionTree def : map fvDecisionTree es

defToVarDefs :: Def -> [(TypedVar, WithPos ([Type], Expr'))]
defToVarDefs = \case
    VarDef d -> [d]
    RecDefs ds -> map (second (mapPosd (second Fun))) ds

funDefFromVarDef :: VarDef -> (TypedVar, WithPos ([Type], Fun))
funDefFromVarDef = second $ mapPosd $ second $ \case
    Fun f -> f
    e -> ice $ "funDefFromVarDef on non-positioned function " ++ show e

M src/Lower.hs => src/Lower.hs +84 -4
@@ 1,7 1,87 @@
module Lower (lower) where
module Lower (lower, builtinExterns) where

import qualified Monomorphic
import Data.Bifunctor
import qualified Data.Map as Map
import Data.Map (Map)

import Misc
import qualified Monomorphic as Ast
import qualified Monomorphize
import Low

lower :: Monomorphic.Program -> Program
lower = id

lower :: Ast.Program -> Program
lower (Ast.Program defs datas externs) =
    Program (lowerDefs defs) (lowerDatas datas) (lowerExterns externs)

builtinExterns :: Map String Type
builtinExterns = fmap lowerType Monomorphize.builtinExterns

lowerDefs :: Ast.Defs -> Defs
lowerDefs (Topo defs) = Topo $ map lowerDef defs

lowerDef :: Ast.Def -> Def
lowerDef = \case
    Ast.VarDef d -> VarDef $ lowerVarDef d
    Ast.RecDefs ds -> RecDefs $ lowerRecDefs ds

lowerVarDef :: Ast.VarDef -> VarDef
lowerVarDef = bimap lowerTypedVar (fmap (bimap (map lowerType) lowerExpr'))

lowerRecDefs :: Ast.RecDefs -> RecDefs
lowerRecDefs = map lowerFunDef

lowerFunDef :: Ast.FunDef -> FunDef
lowerFunDef = bimap lowerTypedVar (fmap (bimap (map lowerType) lowerFun))

lowerFun :: Ast.Fun -> Fun
lowerFun = bimap lowerTypedVar (bimap lowerExpr lowerType)

lowerExpr :: Ast.Expr -> Expr
lowerExpr (Ast.Expr p e) = Expr p (lowerExpr' e)

lowerExpr' :: Ast.Expr' -> Expr'
lowerExpr' = \case
    Ast.Lit c -> Lit c
    Ast.Var tv -> Var $ lowerTypedVar tv
    Ast.App f a t -> App (lowerExpr f) (lowerExpr a) (lowerType t)
    Ast.If p c a -> If (lowerExpr p) (lowerExpr c) (lowerExpr a)
    Ast.Fun f -> Fun (lowerFun f)
    Ast.Let d e -> Let (lowerDef d) (lowerExpr e)
    Ast.Match m dt t -> Match (lowerExpr m) (lowerDecisionTree dt) (lowerType t)
    Ast.Ction c -> Ction $ lowerCtion c
    Ast.Sizeof t -> Sizeof $ lowerType t
    Ast.Absurd t -> Absurd $ lowerType t

lowerDecisionTree :: Ast.DecisionTree -> DecisionTree
lowerDecisionTree = \case
    Ast.DLeaf (bs, e) -> DLeaf (map (bimap lowerTypedVar lowerAccess) bs, lowerExpr e)
    Ast.DSwitch a cs def ->
        DSwitch (lowerAccess a) (fmap lowerDecisionTree cs) (lowerDecisionTree def)
    Ast.DSwitchStr a cs def ->
        DSwitchStr (lowerAccess a) (fmap lowerDecisionTree cs) (lowerDecisionTree def)

lowerAccess :: Ast.Access -> Access
lowerAccess = fmap lowerType

lowerCtion :: Ast.Ction -> Ction
lowerCtion (i, s, tc, es) = (i, s, lowerTConst tc, map lowerExpr es)

lowerDatas :: Ast.Datas -> Datas
lowerDatas = Map.fromList . map (bimap lowerTConst (map (map lowerType))) . Map.toList

lowerExterns :: Ast.Externs -> Externs
lowerExterns = map (\(x, t, p) -> (x, lowerType t, p))

lowerTypedVar :: Ast.TypedVar -> TypedVar
lowerTypedVar (Ast.TypedVar x t) = TypedVar x (lowerType t)

lowerTConst :: Ast.TConst -> TConst
lowerTConst = second (map lowerType)

lowerType :: Ast.Type -> Type
lowerType = \case
    Ast.TPrim p -> TPrim p
    Ast.TFun a r -> TFun (lowerType a) (lowerType r)
    Ast.TBox t -> TBox (lowerType t)
    Ast.TConst tc -> TConst (lowerTConst tc)

M src/Misc.hs => src/Misc.hs +2 -0
@@ 1,3 1,5 @@
{-# LANGUAGE RankNTypes #-}

module Misc where

import Data.List (intercalate)

M src/Monomorphic.hs => src/Monomorphic.hs +12 -5
@@ 32,13 32,15 @@ data TypedVar = TypedVar String Type

type VariantTypes = [Type]

data Access
data Access' t
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    | As (Access' t) Span [t]
    | Sel Word32 Span (Access' t)
    | ADeref (Access' t)
    deriving (Show, Eq, Ord)

type Access = Access' Type

type VarBindings = [(TypedVar, Access)]

data DecisionTree


@@ 77,7 79,6 @@ type Externs = [(String, Type, SrcPos)]
data Program = Program Defs Datas Externs
    deriving Show


instance TypeAst Type where
    tprim = TPrim
    tconst = TConst


@@ 90,6 91,12 @@ instance FreeVars Expr TypedVar where
instance FreeVars Expr' TypedVar where
    freeVars = fvExpr'

instance Functor Access' where
    fmap f = \case
        Obj -> Obj
        As a s ts -> As (fmap f a) s (map f ts)
        Sel i s a -> Sel i s (fmap f a)
        ADeref a -> ADeref (fmap f a)

expr' :: Expr -> Expr'
expr' (Expr _ e) = e

M src/SrcPos.hs => src/SrcPos.hs +3 -0
@@ 27,6 27,9 @@ instance Ord a => Ord (WithPos a) where
instance HasPos (WithPos a) where
    getPos (WithPos p _) = p

instance Functor WithPos where
    fmap = mapPosd

mapPosd :: (a -> b) -> WithPos a -> WithPos b
mapPosd f (WithPos p a) = WithPos p (f a)