~jojo/Carth

9fa96556b580885948ac79dc9f7618657be1fcd6 — Johan Johansson 2 years ago e20e0bc
Start getting some structure. Begin impl gen of const
5 files changed, 92 insertions(+), 66 deletions(-)

M package.yaml
M src/Annot.hs
M src/Check.hs
M src/Codegen.hs
M stack.yaml
M package.yaml => package.yaml +2 -1
@@ 30,6 30,7 @@ dependencies:
- utility-ht
- llvm-hs-pure == 8.0.0
- llvm-hs == 8.0.0
- llvm-hs-pretty
- filepath
- bytestring



@@ 49,7 50,7 @@ library:
  - -fno-warn-incomplete-record-updates

executables:
  carth-exe:
  carthe:
    main:                Main.hs
    source-dirs:         app
    ghc-options:

M src/Annot.hs => src/Annot.hs +1 -0
@@ 4,6 4,7 @@ module Annot
    ( Program(..)
    , Expr(..)
    , Type(..)
    , Const(..)
    , typeUnit
    , typeInt
    , typeDouble

M src/Check.hs => src/Check.hs +0 -1
@@ 50,7 50,6 @@ data Scheme = Forall
    { _scmParams :: (Set TVar)
    , _scmBody :: Type
    } deriving (Show, Eq)

makeLenses ''Scheme

newtype Defs =

M src/Codegen.hs => src/Codegen.hs +87 -64
@@ 1,85 1,108 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings, LambdaCase, TemplateHaskell #-}

module Codegen where

import qualified LLVM.AST as L
import LLVM.AST
import qualified LLVM.AST.CallingConvention as CallConv
import qualified LLVM.AST.Constant as C
import qualified LLVM.AST.Global as G
import qualified LLVM.AST.Instruction as I
import qualified LLVM.AST.Operand as O
import qualified LLVM.AST.Type as T
import qualified LLVM.AST.Constant as LLConst
import qualified LLVM.AST.Global as LLGlob
import qualified LLVM.AST.Type as LLType
import Data.String
import System.FilePath
import Control.Monad.Writer
-- import Control.Lens (makeLenses)

import qualified Annot as An
import qualified Mono

genModule :: FilePath -> Mono.MExpr -> Mono.Defs -> L.Module
genModule moduleFilePath main defs = L.defaultModule
    { L.moduleName = fromString ((takeBaseName moduleFilePath))
    , L.moduleSourceFileName = fromString moduleFilePath
    , L.moduleDefinitions = genMain main : genDefs defs
-- data St = St
--     { blocks :: [BasicBlock] }
-- makeLenses ''St

type Gen a = Writer [BasicBlock] a

genModule :: FilePath -> Mono.MExpr -> Mono.Defs -> Module
genModule moduleFilePath main defs = defaultModule
    { moduleName = fromString ((takeBaseName moduleFilePath))
    , moduleSourceFileName = fromString moduleFilePath
    , moduleDefinitions = genMain main : genDefs defs
    }

genMain :: Mono.MExpr -> L.Definition
genMain main = undefined
    main
    (L.GlobalDefinition
        (G.functionDefaults
            { G.name = "main"
            , G.parameters = ([], False)
            , G.returnType = T.VoidType
            , G.basicBlocks = [mainEntry]
            }
        )
genMain :: Mono.MExpr -> Definition
genMain main = GlobalDefinition
    (functionDefaults
        { LLGlob.name = "main"
        , LLGlob.parameters = ([], False)
        , LLGlob.returnType = VoidType
        , LLGlob.basicBlocks = execWriter (genExpr main)
        }
    )

mainEntry :: L.BasicBlock
mainEntry = G.BasicBlock
genExpr :: Mono.MExpr -> Gen Operand
genExpr = \case
    An.Lit c -> pure (ConstantOperand (toLlvmConstant c))
    An.Var _ _ -> undefined
    An.App _ _ -> undefined
    An.If _ _ _ -> undefined
    An.Fun _ _ -> undefined
    An.Let _ _ -> undefined
    -- main


toLlvmConstant :: An.Const -> LLConst.Constant
toLlvmConstant = \case
    An.Unit -> litStruct []
    An.Int _ -> undefined
    An.Double _ -> undefined
    An.Char _ -> undefined
    An.Str _ -> undefined
    An.Bool _ -> undefined

litStruct :: [LLConst.Constant] -> LLConst.Constant
litStruct = LLConst.Struct Nothing False

mainEntry :: BasicBlock
mainEntry = BasicBlock
    "entry"
    [ I.Do
          (I.Call
              { I.tailCallKind = Nothing
              , I.callingConvention = CallConv.C
              , I.returnAttributes = []
              , I.function = Right
                  (O.ConstantOperand
                      (C.GlobalReference
                          (T.ptr
                              (T.FunctionType
                                  { T.argumentTypes = [T.i8]
                                  , T.resultType = T.i32
                                  , T.isVarArg = False
                                  }
                              )
    [ Do $ Call
          { tailCallKind = Nothing
          , callingConvention = CallConv.C
          , returnAttributes = []
          , function = Right
              (ConstantOperand
                  (LLConst.GlobalReference
                      (LLType.ptr
                          (FunctionType
                              { argumentTypes = [LLType.i8]
                              , resultType = LLType.i32
                              , isVarArg = False
                              }
                          )
                          "putchar"
                      )
                      "putchar"
                  )
              , I.arguments = [ ( O.ConstantOperand
                                    (C.Int
                                        { C.integerBits = 8
                                        , C.integerValue = 65
                                        }
                                    )
                                , []
                                )
                              ]
              , I.functionAttributes = []
              , I.metadata = []
              }
          )
              )
          , arguments = [ ( ConstantOperand
                              (LLConst.Int
                                  { LLConst.integerBits = 8
                                  , LLConst.integerValue = 65
                                  }
                              )
                          , []
                          )
                        ]
          , functionAttributes = []
          , metadata = []
          }
    ]
    (I.Do (I.Ret Nothing []))
    (Do (Ret Nothing []))

genDefs :: Mono.Defs -> [L.Definition]
genDefs :: Mono.Defs -> [Definition]
genDefs defs = undefined defs [putchar]

putchar :: L.Definition
putchar = L.GlobalDefinition
    (G.functionDefaults
        { G.name = "putchar"
        , G.parameters = ([G.Parameter T.i8 "x" []], False)
        , G.returnType = T.i32
        }
    )
putchar :: Definition
putchar = GlobalDefinition $ functionDefaults
    { LLGlob.name = "putchar"
    , LLGlob.parameters = ([LLGlob.Parameter LLType.i8 "x" []], False)
    , LLGlob.returnType = LLType.i32
    }

M stack.yaml => stack.yaml +2 -0
@@ 41,6 41,8 @@ packages:
# extra-deps: []
extra-deps:
- llvm-hs-8.0.0@sha256:bca4c990e355cb4d2ed02d22dd076fe84ffc76f7b5330797c54ff449037a9efc
- github: llvm-hs/llvm-hs-pretty
  commit: /852ea9fd3bedf84b203db0a2cb870c00acd92add

# Override default flag values for local packages and extra-deps
# flags: {}