Commit 85ea89d7 authored by Pavel Zakopaylo's avatar Pavel Zakopaylo

Fixed type-related bug in primordial function generation

parent d06055ae
......@@ -256,7 +256,7 @@ data MuState = MuState
, _definitions :: Seq Definition
, _topLevels :: Seq TopLevel
, _topBinds :: M.Map GHC.Id GlobalCellName
, _mainFunc :: Maybe (VarName, VarName)
, _mainFunc :: Maybe (VarName, VarName, TypedefName)
}
uniqueID :: Lens' MuState Int
......@@ -274,7 +274,7 @@ topLevels k m = fmap (\new -> m { _topLevels = new }) (k (_topLevels m))
topBinds :: Lens' MuState (M.Map GHC.Id GlobalCellName)
topBinds k m = fmap (\new -> m { _topBinds = new }) (k (_topBinds m))
mainFunc :: Lens' MuState (Maybe (VarName, VarName))
mainFunc :: Lens' MuState (Maybe (VarName, VarName, TypedefName))
mainFunc k m = fmap (\new -> m { _mainFunc = new }) (k (_mainFunc m))
-------------------------------------------------- * Block building monad
......@@ -443,11 +443,11 @@ bundleMu modName codegen = runMu initialState $ do
-- | Generates main function that evaluates selected closure
-- NOTE: Will fail (VM panic) if called (with Just) multiple times
haskellMain :: Maybe (VarName, VarName) -> Mu (Maybe FunctionName)
haskellMain :: Maybe (VarName, VarName, TypedefName) -> Mu (Maybe FunctionName)
haskellMain m = case m of
Nothing -> return Nothing
Just (entry, closure) -> do
Just (entry, closure, closMuRefType) -> do
typedef "@pi8" $ UPtr i8
typedef "@ppi8" $ UPtr "@pi8"
funcsig "@_haskell_main_sig" [i64, "@ppi8"] []
......@@ -456,7 +456,12 @@ haskellMain m = case m of
basicBlock "@_haskell_main.entry"
[("@_haskell_main.entry.argc", i64),
("@_haskell_main.entry.argv", "@ppi8")] $ do
return $ TailCall muClosureFunctionSig entry [closure]
emit' $ ["@_haskell_main.entry.target"] :=
ConvertOperation REFCAST closMuRefType
muClosureIref closure
return $ TailCall muClosureFunctionSig entry
["@_haskell_main.entry.target"]
return $ Just "@_haskell_main"
......@@ -504,9 +509,14 @@ closure name table payload = do
-- a different payload.
definitions %= (|> TypeDefinition closMuType (Struct $
muClosure : map unboxedType payload))
definitions %= (|> TypeDefinition closMuRefType (IRef closMuType))
where
name' = closureNameOf name
closMuType = closureTypeNameOf name
closMuRefType = closureRefTypeNameOf name
-- | Emit a string. The string itself will be allocated during build time.
......@@ -574,6 +584,9 @@ closureNameOf' n = VarName $ Name $ stringify n <> "_closure"
closureTypeNameOf :: (Uniquable a, NamedThing a) => a -> TypedefName
closureTypeNameOf n = TypedefName $ Name $ stringify n <> "_clostype"
closureRefTypeNameOf :: (Uniquable a, NamedThing a) => a -> TypedefName
closureRefTypeNameOf n = TypedefName $ Name $ stringify n <> "_refclostype"
entryNameOf :: GHC.Id -> FunctionName
entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
......
......@@ -212,7 +212,8 @@ codegenTop' name rhs = do
mod <- gets _moduleName
when (tail (stringify name) == ("zdmainzd" <> mod <> "zdmain")) $ do
traceM "Found main method!"
modify (\v -> v { _mainFunc = Just (entry, closureNameOf' name) })
modify (\v -> v { _mainFunc = Just (entry, closureNameOf' name,
closureRefTypeNameOf name) })
topBinds %= (M.insert name $ closureNameOf name)
case rhs of
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment