~jojo/Carth

81952f3fa008b16c413c2c0438847e084137e28c — JoJo 1 year, 7 months ago 758dc41
Add rudimentary DWARF debugging

Can now view stacktrace with line numbers in GDB. Can step
line-by-line and see position in source with `gdb -tui` (although it's
somewhat crippled by not being statement-based like C etc).
M TODO.org => TODO.org +4 -0
@@ 456,3 456,7 @@ the fix etc:
  all public-facing polymorphic functions? Should require some keyword
  or special form, like `boxed`, to make it clear when the FFI will be
  affected.
* NEXT Add separate pass before Codegen to compile SrcPos:s
  I think it could be done purely and independently from rest of codegen. Would be more clean.
* NEXT Refactor Codegen
  It's getting big, complex, and unwieldy. Probably buggy as well.

M src/Abi.hs => src/Abi.hs +8 -12
@@ 15,7 15,6 @@
--   are passed how.
module Abi
    ( simpleFunc
    , simpleFunc'
    , simpleGlobVar
    , simpleGlobVar'
    , passByRef


@@ 26,6 25,7 @@ module Abi
    )
where

import LLVM.Prelude (ShortByteString)
import LLVM.AST
import qualified LLVM.AST.CallingConvention as LLCallConv
import qualified LLVM.AST.Linkage as LLLink


@@ 34,7 34,6 @@ import qualified LLVM.AST.Constant as LLConst
import LLVM.AST.Global (Parameter)
import qualified LLVM.AST.Global as LLGlob
import qualified LLVM.AST.AddrSpace as LLAddr
import qualified LLVM.AST.FunctionAttribute as LLFnAttr
import Control.Monad.Writer
import qualified Data.Map as Map
import Data.Word


@@ 46,17 45,14 @@ import Monomorphic (Span)
import Gen


simpleFunc :: Name -> [Parameter] -> Type -> [BasicBlock] -> Global
simpleFunc = ($ []) .** simpleFunc'

simpleFunc'
simpleFunc
    :: Name
    -> [Parameter]
    -> Type
    -> [LLFnAttr.FunctionAttribute]
    -> [BasicBlock]
    -> [(ShortByteString, MDRef MDNode)]
    -> Global
simpleFunc' n ps rt fnAttrs bs = Function
simpleFunc n ps rt bs meta = Function
    { LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Default
    , LLGlob.dllStorageClass = Nothing


@@ 65,7 61,7 @@ simpleFunc' n ps rt fnAttrs bs = Function
    , LLGlob.returnType = rt
    , LLGlob.name = n
    , LLGlob.parameters = (ps, False)
    , LLGlob.functionAttributes = map Right fnAttrs
    , LLGlob.functionAttributes = []
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0


@@ 73,14 69,14 @@ simpleFunc' n ps rt fnAttrs bs = Function
    , LLGlob.prefix = Nothing
    , LLGlob.basicBlocks = bs
    , LLGlob.personalityFunction = Nothing
    , LLGlob.metadata = []
    , LLGlob.metadata = meta
    }

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

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


@@ 90,7 86,7 @@ simpleGlobVar' name t init = GlobalVariable
    , LLGlob.unnamedAddr = Nothing
    , LLGlob.isConstant = True
    , LLGlob.type' = t
    , LLGlob.initializer = init
    , LLGlob.initializer = initializer
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0

M src/Check.hs => src/Check.hs +2 -2
@@ 153,7 153,7 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
  where
    boundInDefs :: Inferred.Defs -> Bound
    boundInDefs = mapM_ boundInDef
    boundInDef ((Inferred.Forall tvs _), e) =
    boundInDef (WithPos _ ((Inferred.Forall tvs _), e)) =
        local (Set.union tvs) (boundInExpr e)
    boundInExpr (WithPos pos e) = case e of
        Inferred.Lit _ -> pure ()


@@ 200,7 200,7 @@ compileDecisionTrees
compileDecisionTrees tdefs = compDefs
  where
    compDefs = mapM compDef
    compDef = bimapM pure compExpr
    compDef (WithPos p rhs) = fmap (WithPos p) (secondM compExpr rhs)
    compExpr :: Inferred.Expr -> Except TypeErr Checked.Expr
    compExpr (WithPos pos ex) = fmap (withPos pos) $ case ex of
        Inferred.Lit c -> pure (Checked.Lit c)

M src/Checked.hs => src/Checked.hs +1 -1
@@ 82,7 82,7 @@ withPos = Expr . Just
noPos :: Expr' -> Expr
noPos = Checked.Expr Nothing

type Defs = Map String (Scheme, Expr)
type Defs = Map String (WithPos (Scheme, Expr))
type TypeDefs = Map String ([TVar], [[Type]])
type Externs = Map String Type


M src/Codegen.hs => src/Codegen.hs +216 -74
@@ 3,11 3,15 @@
-- | Generation of LLVM IR code from our monomorphic AST.
module Codegen (codegen) where

import LLVM.Prelude (ShortByteString)
import LLVM.AST hiding (args)
import LLVM.AST.Typed
import LLVM.AST.Type hiding (ptr)
import LLVM.AST.DataLayout
import LLVM.AST.ParameterAttribute
import qualified LLSubprog
import qualified LLCompunit
import qualified LLVM.AST.Operand as LLOp
import qualified LLVM.AST.Type as LLType
import qualified LLVM.AST.Constant as LLConst
import qualified LLVM.AST.Float as LLFloat


@@ 25,10 29,12 @@ import Data.Maybe
import Data.Foldable
import Data.List
import Data.Functor
import Data.Bifunctor
import Control.Applicative
import Lens.Micro.Platform (modifying, use, assign, to, view)

import Misc
import SrcPos
import Pretty
import FreeVars
import qualified Monomorphic


@@ 59,24 65,25 @@ codegen :: DataLayout -> FilePath -> Program -> Module
codegen layout moduleFilePath (Program defs tdefs externs) =
    let
        defs' = Map.toList defs
        initEnv = Env
            { _env = Map.empty
            , _dataTypes = Map.empty
            , _srcPos = ice "Read Env.srcPos before it's been set"
            }
        initEnv =
            Env { _env = Map.empty, _dataTypes = Map.empty, _srcPos = Nothing }
        initSt = St
            { _currentBlockLabel = "entry"
            , _currentBlockInstrs = []
            , _registerCount = 0
            , _metadataCount = 3
            , _lambdaParentFunc = Nothing
            , _outerLambdaN = 1
            -- TODO: Maybe add a pass before this that just generates all
            --       SrcPos:s, separately and more cleanly?
            , _srcPosToMetadata = Map.empty
            }
        runGen' g = runReader (evalStateT g initSt) initEnv
        (tdefs', externs', globDefs) = runGen' $ do
            tdefs'' <- defineDataTypes tdefs
            withDataTypes tdefs''
                $ withExternSigs externs
                $ withGlobDefSigs defs'
                $ withGlobDefSigs (map (second unpos) defs')
                $ do
                    es <- genExterns externs
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs'))


@@ 93,6 100,7 @@ codegen layout moduleFilePath (Program defs tdefs externs) =
            , genBuiltins
            , externs'
            , globDefs
            , globMetadataDefs
            ]
        }
  where


@@ 116,6 124,56 @@ codegen layout moduleFilePath (Program defs tdefs externs) =
                    (mkName (mangleName (x, us)))
                )
        augment env (Map.fromList sigs') ga
    fileId = MetadataNodeID 1
    debugInfoVersionId = MetadataNodeID 2
    globMetadataDefs =
        [ MetadataNodeDefinition compileUnitId
            $ DINode (LLOp.DIScope (LLOp.DICompileUnit compileUnitDef))
        , MetadataNodeDefinition fileId
            $ DINode (LLOp.DIScope (LLOp.DIFile fileDef))
        , MetadataNodeDefinition debugInfoVersionId $ MDTuple
            [ Just (MDValue (litI32 2))
            , Just (MDString "Debug Info Version")
            , Just (MDValue (litI32 3))
            ]
        , NamedMetadataDefinition "llvm.dbg.cu" [compileUnitId]
        , NamedMetadataDefinition "llvm.module.flags" [debugInfoVersionId]
        ]
    compileUnitDef = LLCompunit.CompileUnit
        { LLCompunit.language =
            let unstandardized_c = 1 in unstandardized_c
        , LLCompunit.file = MDRef fileId
        , LLCompunit.producer = "carth version alpha"
        , LLCompunit.optimized = False
        , LLCompunit.flags = ""
        , LLCompunit.runtimeVersion = 0
        , LLCompunit.splitDebugFileName = ""
        , LLCompunit.emissionKind = LLOp.FullDebug
        , LLCompunit.enums = []
        , LLCompunit.retainedTypes = []
        , LLCompunit.globals = []
        , LLCompunit.imports = []
        , LLCompunit.macros = []
        , LLCompunit.dWOId = 0
        , LLCompunit.splitDebugInlining = False
        , LLCompunit.debugInfoForProfiling = False
        , LLCompunit.nameTableKind = LLOp.NameTableKindNone
        , LLCompunit.debugBaseAddress = False
        }
    fileDef =
        let (dir, file) = splitFileName moduleFilePath
        in
            LLOp.File
                { LLSubprog.filename = fromString file
                , LLSubprog.directory = fromString dir
                , LLSubprog.checksum = Nothing
                }

compileUnitRef :: MDRef LLOp.DICompileUnit
compileUnitRef = MDRef compileUnitId

compileUnitId :: MetadataNodeID
compileUnitId = MetadataNodeID 0

-- | A data-type is a tagged union, and we represent it in LLVM as a struct
--   where, if there are more than 1 variant, the first element is the


@@ 136,7 194,7 @@ defineDataTypes tds = do

genBuiltins :: [Definition]
genBuiltins = map
    (\(x, (ps, tr)) -> GlobalDefinition (simpleFunc (mkName x) ps tr []))
    (\(x, (ps, tr)) -> GlobalDefinition (simpleFunc (mkName x) ps tr [] []))
    (Map.toList builtins)

builtins :: Map String ([Parameter], Type)


@@ 162,11 220,11 @@ genMain :: Gen' Definition
genMain = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ <- execWriterT $ do
    Out basicBlocks _ _ _ <- execWriterT $ do
        f <- lookupVar (TypedVar "start" startType)
        _ <- app f (VLocal litUnit) typeUnit
        commitFinalFuncBlock (ret (litI32 0))
    pure (GlobalDefinition (simpleFunc (mkName "main") [] i32 basicBlocks))
    pure (GlobalDefinition (simpleFunc (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


@@ 174,70 232,77 @@ genMain = do
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef :: (TypedVar, ([Monomorphic.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, (ts, (Expr maybePos e))) =
    let
        pos = fromMaybe
            (ice "rhs expr doesn't have srcpos in genGlobDef")
            maybePos
    in
        case e of
            Fun p (body, _) -> do
                let var = (v, ts)
                let name = mangleName var
                assign lambdaParentFunc (Just name)
                assign outerLambdaN 1
                let fName = mkName (name ++ "_func")
                (f, gs) <- locallySet srcPos pos
                    $ genFunDef (fName, [], p, body)
                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 (map GlobalDefinition (closureDef : f : gs))
            _ -> nyi $ "Global non-function defs: " ++ show e
genGlobDef
    :: (TypedVar, WithPos ([Monomorphic.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
    Fun p (body, _) -> 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, body)
        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

-- | Generates a function definition
--
--   The signature definition, the parameter-loading, and the result return are
--   all done according to the calling convention.
genFunDef :: (Name, [TypedVar], TypedVar, Expr) -> Gen' (Global, [Global])
genFunDef (name, fvs, ptv@(TypedVar px pt), body) = do
genFunDef
    :: (Name, [TypedVar], SrcPos, TypedVar, Expr) -> Gen' (Global, [Definition])
genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), body) = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    ((rt, fParams), Out basicBlocks globStrings lambdaFuncs) <- runWriterT $ do
        (capturesParam, captureLocals) <- genExtractCaptures
        pt' <- genType pt
        px' <- newName px
        -- Load params according to calling convention
        passParamByRef <- passByRef pt'
        let (withParam, pt'', pattrs) = if passParamByRef
                then (withVar, LLType.ptr pt', [ByVal])
                else (withLocal, pt', [])
        let pRef = LocalReference pt'' px'
        result <- getLocal
            =<< withParam ptv pRef (withLocals captureLocals (genExpr body))
        let rt' = typeOf result
        let fParams' =
                [uncurry Parameter capturesParam [], Parameter pt'' px' pattrs]
        -- Return result according to calling convention
        returnResultByRef <- passByRef rt'
        if returnResultByRef
            then do
                let out = (LLType.ptr rt', mkName "out")
                emitDo (store result (uncurry LocalReference out))
                commitFinalFuncBlock retVoid
                pure (LLType.void, uncurry Parameter out [SRet] : fParams')
            else do
                commitFinalFuncBlock (ret result)
                pure (rt', fParams')
    ((rt, fParams), Out basicBlocks globStrings lambdaFuncs srcPoss) <-
        runWriterT $ do
            -- Two equal SrcPos's in different scopes are not equal at the
            -- metadata level. Reset cache every scope.
            assign srcPosToMetadata Map.empty
            (capturesParam, captureLocals) <- genExtractCaptures
            pt' <- genType pt
            px' <- newName px
            -- Load params according to calling convention
            passParamByRef <- passByRef pt'
            let (withParam, pt'', pattrs) = if passParamByRef
                    then (withVar, LLType.ptr pt', [ByVal])
                    else (withLocal, pt', [])
            let pRef = LocalReference pt'' px'
            result <- getLocal =<< withParam
                ptv
                pRef
                (withLocals captureLocals (genExpr body))
            let rt' = typeOf result
            let
                fParams' =
                    [ uncurry Parameter capturesParam []
                    , Parameter pt'' px' pattrs
                    ]
            -- Return result according to calling convention
            returnResultByRef <- passByRef rt'
            if returnResultByRef
                then do
                    let out = (LLType.ptr rt', mkName "out")
                    emitDo (store result (uncurry LocalReference out))
                    commitFinalFuncBlock retVoid
                    pure (LLType.void, uncurry Parameter out [SRet] : fParams')
                else do
                    commitFinalFuncBlock (ret result)
                    pure (rt', fParams')
    (funScopeMdId, funScopeMdDef) <- defineFunScopeMetadata
    ss <- mapM globStrVar globStrings
    ls <- fmap concat (mapM (fmap (uncurry (:)) . genFunDef) lambdaFuncs)
    let f = simpleFunc name fParams rt basicBlocks
    pure (f, concat ss ++ ls)
    ls <- fmap
        concat
        (mapM (fmap (uncurry ((:) . GlobalDefinition)) . genFunDef) lambdaFuncs)
    ps <- mapM (defineSrcPos (MDRef funScopeMdId)) srcPoss
    let f =
            simpleFunc name fParams rt basicBlocks [("dbg", MDRef funScopeMdId)]
    pure (f, concat ss ++ ls ++ (funScopeMdDef : ps))
  where
    globStrVar (strName, s) = do
        name_inner <- newName' "strlit_inner"


@@ 255,7 320,7 @@ genFunDef (name, fvs, ptv@(TypedVar px pt), body) = do
                [ptrBytes, litI64' len]
            str = litStructNamed' ("Str", []) [array]
            defStr = simpleGlobVar strName typeStr str
        pure [defInner, defStr]
        pure (map GlobalDefinition [defInner, defStr])
    genExtractCaptures = do
        capturesName <- newName "captures"
        let capturesPtrGenericType = LLType.ptr typeUnit


@@ 275,9 340,63 @@ genFunDef (name, fvs, ptv@(TypedVar px pt), body) = do
                    )
                    (zip fvs [0 ..])
                pure (zip fvs captureVals)
    defineSrcPos funScopeMdRef (SrcPos (SourcePos _fp l c), mdId) = do
        let (line, col) = both unPos (l, c)
            loc =
                LLOp.DILocation
                    $ LLOp.Location (fromIntegral line) (fromIntegral col)
                    $ funScopeMdRef
        pure (MetadataNodeDefinition mdId loc)
    defineFunScopeMetadata :: Gen' (MetadataNodeID, Definition)
    defineFunScopeMetadata = do
        mdId <- newMetadataId'
        pure
            ( mdId
            , MetadataNodeDefinition
                mdId
                (DINode $ LLOp.DIScope $ LLOp.DILocalScope
                    (LLOp.DISubprogram funMetadataSubprog)
                )
            )
    funMetadataSubprog =
        let
            SrcPos (SourcePos path line' _) = dpos
            line = fromIntegral (unPos line')
            -- TODO: Maybe only define this once and cache MDRef somewhere?
            fileNode =
                let (dir, file) = splitFileName path
                in
                    LLSubprog.File
                        { LLSubprog.filename = fromString file
                        , LLSubprog.directory = fromString dir
                        , LLSubprog.checksum = Nothing
                        }
        in LLOp.Subprogram
            { LLSubprog.scope = Just (MDInline (LLOp.DIFile fileNode))
            , LLSubprog.name = nameSBString name
            , LLSubprog.linkageName = nameSBString name
            , LLSubprog.file = Just (MDInline fileNode)
            , LLSubprog.line = line
            , LLSubprog.type' = Just
                (MDInline (LLOp.SubroutineType [] 0 []))
            , LLSubprog.localToUnit = True
            , LLSubprog.definition = True
            , LLSubprog.scopeLine = line
            , LLSubprog.containingType = Nothing
            , LLSubprog.virtuality = LLOp.NoVirtuality
            , LLSubprog.virtualityIndex = 0
            , LLSubprog.thisAdjustment = 0
            , LLSubprog.flags = []
            , LLSubprog.optimized = False
            , LLSubprog.unit = Just compileUnitRef
            , LLSubprog.templateParams = []
            , LLSubprog.declaration = Nothing
            , LLSubprog.retainedNodes = []
            , LLSubprog.thrownTypes = []
            }

genExpr :: Expr -> Gen Val
genExpr (Expr pos expr) = locally srcPos (flip fromMaybe pos) $ do
genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
    parent <- use lambdaParentFunc <* assign lambdaParentFunc Nothing
    case expr of
        Lit c -> genConst c


@@ 387,7 506,7 @@ genLet ds b = do
        t' <- genType t
        emitReg n (alloca t')
    withVars (zip vs ps) $ do
        forM_ (zip ps es) $ \(p, (_, e)) -> do
        forM_ (zip ps es) $ \(p, WithPos _ (_, e)) -> do
            x <- getLocal =<< genExpr e
            emitDo (store x p)
        genExpr b


@@ 522,7 641,8 @@ genLambda p@(TypedVar px pt) (b, bt) = do
        f = VLocal $ ConstantOperand $ LLConst.GlobalReference
            (LLType.ptr ft)
            fname
    scribe outFuncs [(fname, fvXs, p, b)]
    pos <- view (srcPos . to (fromMaybe (ice "srcPos is Nothing in genLambda")))
    scribe outFuncs [(fname, fvXs, pos, p, b)]
    genStruct [captures, f]

genStruct :: [Val] -> Gen Val


@@ 679,13 799,24 @@ emitNamedReg :: Name -> FunInstr -> Gen Operand
        emit' (reg :=) instr $> LocalReference rt reg
    )
  where
    emit' :: (Instruction -> Named Instruction) -> Instr -> Gen ()
    emit' nameInstruction instr = do
        _pos <- view srcPos
        meta <- -- TODO:
                --   loc <- genSrcPos p
                --   pure [("dbg", loc)]
                pure []
        meta <- view srcPos >>= \case
            Just pos -> do
                loc <- genSrcPos pos
                pure [("dbg", loc)]
            Nothing -> pure []
        modifying currentBlockInstrs (nameInstruction (instr meta) :)
    genSrcPos :: SrcPos -> Gen (MDRef MDNode)
    genSrcPos pos = do
        use (srcPosToMetadata . to (Map.lookup pos)) >>= \case
            Just mdRef -> pure mdRef
            Nothing -> do
                mdId <- newMetadataId
                let mdRef = MDRef mdId
                scribe outSrcPos [(pos, mdId)]
                modifying srcPosToMetadata (Map.insert pos mdRef)
                pure (mdRef)

emitReg :: String -> FunInstr -> Gen Operand
emitReg s instr = newName s >>= flip emitNamedReg instr


@@ 713,6 844,12 @@ newName = lift . newName'
newName' :: String -> Gen' Name
newName' s = fmap (mkName . (s ++) . show) (registerCount <<+= 1)

newMetadataId :: Gen MetadataNodeID
newMetadataId = lift newMetadataId'

newMetadataId' :: Gen' MetadataNodeID
newMetadataId' = fmap MetadataNodeID (metadataCount <<+= 1)

callExtern :: String -> [Operand] -> FunInstr
callExtern f as =
    let


@@ 892,3 1029,8 @@ lookupVar x = do
    view (env . to (Map.lookup x)) >>= \case
        Just var -> pure (VVar var)
        Nothing -> ice $ "Undefined variable " ++ show x

nameSBString :: Name -> ShortByteString
nameSBString = \case
    Name s -> s
    UnName n -> fromString (show n)

M src/Compile.hs => src/Compile.hs +1 -0
@@ 30,6 30,7 @@ compileModule t cfg m = do
    let exefile = outfile cfg
        ofile = replaceExtension exefile "o"
    when (debug cfg) $ writeLLVMAssemblyToFile' ".dbg.ll" m
    putStrLn ("   Verifying LLVM")
    verify m
    writeObjectToFile t (File ofile) m
    putStrLn ("   Linking")

M src/Gen.hs => src/Gen.hs +11 -5
@@ 7,12 7,15 @@ module Gen
    , outBlocks
    , outStrings
    , outFuncs
    , outSrcPos
    , St(..)
    , currentBlockLabel
    , currentBlockInstrs
    , registerCount
    , metadataCount
    , lambdaParentFunc
    , outerLambdaN
    , srcPosToMetadata
    , Env(..)
    , env
    , dataTypes


@@ 39,7 42,7 @@ data Env = Env
    --       or local?
    { _env :: Map TypedVar Operand -- ^ Environment of stack allocated variables
    , _dataTypes :: Map Name Type
    , _srcPos :: SrcPos
    , _srcPos :: Maybe SrcPos
    }
makeLenses ''Env



@@ 47,10 50,12 @@ data St = St
    { _currentBlockLabel :: Name
    , _currentBlockInstrs :: [Named Instruction]
    , _registerCount :: Word
    , _metadataCount :: Word
    -- | Keep track of the parent function name so that we can name the
    --   outermost lambdas of a function definition well.
    , _lambdaParentFunc :: Maybe String
    , _outerLambdaN :: Word
    , _srcPosToMetadata :: Map SrcPos (MDRef MDNode)
    }
makeLenses ''St



@@ 61,7 66,8 @@ type Gen' = StateT St (Reader Env)
data Out = Out
    { _outBlocks :: [BasicBlock]
    , _outStrings :: [(Name, String)]
    , _outFuncs :: [(Name, [TypedVar], TypedVar, Expr)]
    , _outFuncs :: [(Name, [TypedVar], SrcPos, TypedVar, Expr)]
    , _outSrcPos :: [(SrcPos, MetadataNodeID)]
    }
makeLenses ''Out



@@ 69,10 75,10 @@ type Gen = WriterT Out Gen'


instance Semigroup Out where
    Out bs1 ss1 fs1 <> Out bs2 ss2 fs2 =
        Out (bs1 <> bs2) (ss1 <> ss2) (fs1 <> fs2)
    Out bs1 ss1 fs1 ps1 <> Out bs2 ss2 fs2 ps2 =
        Out (bs1 <> bs2) (ss1 <> ss2) (fs1 <> fs2) (ps1 <> ps2)
instance Monoid Out where
    mempty = Out [] [] []
    mempty = Out [] [] [] []


lookupDatatype :: Name -> Gen' Type

M src/Infer.hs => src/Infer.hs +6 -3
@@ 147,7 147,8 @@ inferDefsComponents = \case
                AcyclicSCC vert -> ([vert], False)
                CyclicSCC verts' -> (verts', True)
        let (idents, rhss) = unzip verts
        let (mayscms, bodies) = unzip rhss
        let (poss, mayscms, bodies) =
                unzip3 (map (\(WithPos p (x, y)) -> (p, x, y)) rhss)
        let names = map idstr idents
        mayscms' <- mapM checkScheme (zip names mayscms)
        ts <- replicateM (length names) fresh


@@ 166,7 167,9 @@ inferDefsComponents = \case
                pure body'
        generalizeds <- mapM generalize ts
        let scms' = zipWith fromMaybe generalizeds mayscms'
        let annotDefs = Map.fromList (zip names (zip scms' bodies'))
        let annotDefs = Map.fromList $ zip
                names
                (map (\(p, x, y) -> WithPos p (x, y)) (zip3 poss scms' bodies'))
        annotRest <- withLocals (zip names scms') (inferDefsComponents sccs)
        pure (Map.union annotRest annotDefs)



@@ 209,7 212,7 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Parsed.Fun p b -> inferFunMatch (pure (p, b))
    Parsed.Let defs b -> do
        annotDefs <- inferDefs defs
        let defsScms = fmap (\(scm, _) -> scm) annotDefs
        let defsScms = fmap (\(WithPos _ (scm, _)) -> scm) annotDefs
        (bt, b') <- withLocals' defsScms (infer b)
        pure (bt, Let annotDefs b')
    Parsed.TypeAscr x t -> do

M src/Inferred.hs => src/Inferred.hs +1 -1
@@ 97,7 97,7 @@ data Expr'

type Expr = WithPos Expr'

type Defs = Map String (Scheme, Expr)
type Defs = Map String (WithPos (Scheme, Expr))
type TypeDefs = Map String ([TVar], [(Id, [Type])])
type Ctors = Map String (VariantIx, (String, [TVar]), [Type], Span)
type Externs = Map String Type

A src/LLCompunit.hs => src/LLCompunit.hs +3 -0
@@ 0,0 1,3 @@
module LLCompunit (DICompileUnit(..)) where

import LLVM.AST.Operand (DICompileUnit(..))

A src/LLSubprog.hs => src/LLSubprog.hs +3 -0
@@ 0,0 1,3 @@
module LLSubprog (DISubprogram(..), DIFile(..)) where

import LLVM.AST.Operand (DISubprogram(..), DIFile(..))

M src/Monomorphic.hs => src/Monomorphic.hs +2 -2
@@ 84,7 84,7 @@ data Expr'
data Expr = Expr (Maybe SrcPos) Expr'
    deriving (Show)

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



@@ 103,7 103,7 @@ fvExpr (Expr _ ex) = case ex of
    App f a _ -> fvApp f a
    If p c a -> fvIf p c a
    Fun p (b, _) -> fvFun p b
    Let bs e -> fvLet (Map.keysSet bs, map snd (Map.elems bs)) e
    Let bs e -> fvLet (Map.keysSet bs, map (snd . unpos) (Map.elems bs)) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e

M src/Monomorphize.hs => src/Monomorphize.hs +4 -2
@@ 18,6 18,7 @@ import Data.Set (Set)
import Data.Bitraversable

import Misc
import SrcPos
import qualified Checked
import Checked (noPos, TVar(..), Scheme(..))
import Monomorphic


@@ 88,13 89,14 @@ monoLet ds body = do
    parentInsts <- use (defInsts . to (lookups ks))
    let newEmptyInsts = (fmap (const Map.empty) ds)
    modifying defInsts (Map.union newEmptyInsts)
    body' <- augment envDefs ds (mono body)
    body' <- augment envDefs (fmap unpos ds) (mono body)
    dsInsts <- use (defInsts . to (lookups ks))
    modifying defInsts (Map.union (Map.fromList parentInsts))
    let ds' = Map.fromList $ do
            (name, dInsts) <- dsInsts
            let pos = getPos (ds Map.! name)
            (t, (us, dbody)) <- Map.toList dInsts
            pure (TypedVar name t, (us, dbody))
            pure (TypedVar name t, WithPos pos (us, dbody))
    pure (ds', body')

monoMatch :: Checked.Expr -> Checked.DecisionTree -> Checked.Type -> Mono Expr'

M src/Parse.hs => src/Parse.hs +8 -4
@@ 62,6 62,7 @@ parseModule
    -> [String]
    -> IO (Either String ([Def], [TypeDef], [Extern]))
parseModule filepath dir m visiteds nexts = do
    -- TODO: make dir absolute to make debug work when binary is moved?
    modPaths <- fmap (dir :) modulePaths
    (src, f) <- parseModule' modPaths
    let visiteds' = Set.insert m visiteds


@@ 161,20 162,20 @@ defTyped pos = reserved "define:" *> def' (fmap Just scheme) pos
def'
    :: Parser (Maybe Scheme)
    -> SrcPos
    -> Parser (Id 'Small, (Maybe Scheme, Expr))
    -> Parser (Id 'Small, (WithPos (Maybe Scheme, Expr)))
def' schemeParser topPos = varDef <|> funDef
  where
    varDef = do
        name <- small'
        scm <- schemeParser
        body <- expr
        pure (name, (scm, body))
        pure (name, (WithPos topPos (scm, body)))
    funDef = do
        (name, params) <- parens (liftM2 (,) small' (some pat))
        scm <- schemeParser
        body <- expr
        let f = foldr (WithPos topPos .* Fun) body params
        pure (name, (scm, f))
        pure (name, (WithPos topPos (scm, f)))

expr :: Parser Expr
expr = withPos $ choice [unit, estr, ebool, var, num, eConstructor, pexpr]


@@ 198,7 199,10 @@ expr = withPos $ choice [unit, estr, ebool, var, num, eConstructor, pexpr]
        pure $ unpos
            (foldr (\p b -> WithPos (getPos p) (Fun p b)) body params)
    let' = reserved "let" *> liftA2 Let (parens (many binding)) expr
    binding = parens (bindingTyped <|> bindingUntyped)
    binding = do
        p <- getSrcPos
        (lhs, rhs) <- parens (bindingTyped <|> bindingUntyped)
        pure (lhs, WithPos p rhs)
    bindingTyped = reserved ":"
        *> liftA2 (,) small' (liftA2 (,) (fmap Just scheme) expr)
    bindingUntyped = liftA2 (,) small' (fmap (Nothing, ) expr)

M src/Parsed.hs => src/Parsed.hs +3 -3
@@ 106,7 106,7 @@ data Expr'

type Expr = WithPos Expr'

type Def = (Id 'Small, (Maybe Scheme, Expr))
type Def = (Id 'Small, (WithPos (Maybe Scheme, Expr)))

newtype ConstructorDefs = ConstructorDefs [(Id 'Big, [Type])]
    deriving (Show, Eq)


@@ 128,7 128,7 @@ instance Eq Pat where
        _ -> False

instance FreeVars Def (Id 'Small) where
    freeVars (_, (_, body)) = freeVars body
    freeVars (_, (WithPos _ (_, body))) = freeVars body

instance FreeVars Expr (Id 'Small) where
    freeVars = fvExpr


@@ 153,7 153,7 @@ fvExpr = unpos >>> \case
    App f a -> fvApp f a
    If p c a -> fvIf p c a
    Fun p b -> fvFun' p b
    Let bs e -> fvLet (Set.fromList (map fst bs), map (snd . snd) bs) e
    Let bs e -> fvLet (Set.fromList (map fst bs), map (snd . unpos . snd) bs) e
    TypeAscr e _ -> freeVars e
    Match e cs -> fvMatch e cs
    FunMatch cs -> fvCases cs

M src/Pretty.hs => src/Pretty.hs +4 -4
@@ 58,12 58,12 @@ prettyProg :: Int -> Parsed.Program -> String
prettyProg d (Parsed.Program defs tdefs externs) =
    let
        prettyDef = \case
            (name, (Just scm, body)) -> concat
            (name, WithPos _ (Just scm, body)) -> concat
                [ indent d ++ "(define: " ++ pretty name ++ "\n"
                , indent (d + 4) ++ pretty' (d + 4) scm ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]
            (name, (Nothing, body)) -> concat
            (name, WithPos _ (Nothing, body)) -> concat
                [ indent d ++ "(define " ++ pretty name ++ "\n"
                , indent (d + 2) ++ pretty' (d + 2) body ++ ")"
                ]


@@ 120,12 120,12 @@ prettyExpr' d = \case
        ]
      where
        prettyDef d' = \case
            (name, (Just scm, dbody)) -> concat
            (name, WithPos _ (Just scm, dbody)) -> concat
                [ "[: " ++ pretty' (d' + 3) name ++ "\n"
                , indent (d' + 3) ++ pretty' (d' + 3) scm ++ "\n"
                , indent (d' + 1) ++ pretty' (d' + 1) dbody ++ "]"
                ]
            (name, (Nothing, dbody)) -> concat
            (name, WithPos _ (Nothing, dbody)) -> concat
                [ "[" ++ pretty' (d' + 1) name ++ "\n"
                , indent (d' + 1) ++ pretty' (d' + 1) dbody ++ "]"
                ]

M src/SrcPos.hs => src/SrcPos.hs +6 -1
@@ 1,8 1,11 @@
module SrcPos
    ( SrcPos(..)
    , SourcePos(..)
    , WithPos(..)
    , HasPos(..)
    , mapPos
    , unpos
    , unPos
    , dummyPos
    , sourcePosPretty
    )


@@ 12,7 15,7 @@ import Text.Megaparsec.Pos


newtype SrcPos = SrcPos SourcePos
    deriving (Show, Eq)
    deriving (Show, Eq, Ord)

data WithPos a = WithPos SrcPos a



@@ 30,6 33,8 @@ instance Ord a => Ord (WithPos a) where
instance HasPos (WithPos a) where
    getPos (WithPos p _) = p

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

unpos :: WithPos a -> a
unpos (WithPos _ a) = a

M src/Subst.hs => src/Subst.hs +3 -2
@@ 7,6 7,7 @@ import Data.Map.Strict (Map)
import Data.Bifunctor
import Data.Maybe

import SrcPos
import Inferred




@@ 16,8 17,8 @@ type Subst = Map TVar Type
substTopDefs :: Subst -> Defs -> Defs
substTopDefs s defs = fmap (substDef s) defs

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

substExpr :: Subst -> Expr -> Expr
substExpr s (WithPos pos expr) = WithPos pos $ case expr of