Commit 6d920c5d authored by Pavel Zakopaylo's avatar Pavel Zakopaylo

Migrated Andrew's code, not compiling

parent 98d5999f
Pipeline #478 canceled with stages
......@@ -50,7 +50,7 @@ main :: IO ()
main = do
inputFiles <- getArgs
b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles
libresults <- mapM compileLibraryFiles libraryFiles
libresults <- return [] -- mapM compileLibraryFiles libraryFiles
case b of
Success results _ _ -> do
doResults lives $ mergeResults $ (loadPrim : concat libresults ++ results')
......
......@@ -140,6 +140,7 @@ type MuResult = (Seq Definition, Seq TopLevel, Maybe FunctionName)
type MuMergedResult = ( Map Name Definition
, Map Name TopLevel
, Maybe FunctionName)
mergeResults :: [MuResult] -> MuMergedResult
mergeResults = foldl' mergeResults' (M.empty, M.empty, Nothing)
where
......
......@@ -54,7 +54,8 @@ import Debug.Trace
-- | Compile the information inside an STG module into a 'Bundle'.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu modName $ do
stgToMu modData (tyCons, bindings) =
bundleMu modName $ do
loadTypes
mapM_ codegenTop bindings
mapM_ codegenType tyCons
......@@ -80,9 +81,7 @@ codegenType tycon = do
-- | Generate the static reference code for the entries of enumerated data
-- types.
codegenEnumerations :: TyCon -> Mu ()
codegenEnumerations _tycon = return ()
-- TODO: not sure if we need this
-- mapM_ go (tyConDataCons tycon)
codegenEnumerations _tycon = mapM_ go (tyConDataCons tycon)
-- | Generate the static closures for data constructor fields.
......@@ -102,6 +101,53 @@ codegenDataCon dcon = do
entry = funcName `dot` "entry"
this = entry `dot` "this"
mucgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> MuCode ()
mucgCase scrut bndr alt_type alts = do
muEmitBlock' [scrut] $ toOL [MuStmt (MuComment "StgCase")]
seq (pprTraceIt "some case" scrut) $ return ()
seq (pprTraceIt "bind it to" bndr) $ return ()
seq (pprTraceIt "some results" alts) $ return ()
-- evaluate scrut and bind it sowhere
_ <- muEvalAndBind scrut bndr
mucgAlts bndr alt_type alts
return ()
where
muEvalAndBind scrut bndr = do
mucgExpr scrut
muEmitBlock $ toOL [MuStmt (MuComment "bind the thing somewhere")]
mucgAlts bndr alt_type alts = void $ case alt_type of
PolyAlt -> muEmitBlock $ toOL [MuStmt (MuComment "PolyAlt")]
UbxTupAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "UbxAlt")]
PrimAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "PrimAlt")]
AlgAlt tycon -> muEmitBlock $ toOL [MuStmt (MuComment "AlgAlt")]
genBinding :: RecFlag -> Id -> StgRhs -> MuCode ()
genBinding rec bndr rhs = do
muBind bndr
case rhs of
StgRhsCon _cc con arg ->
genConstructor con arg
StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
genClosure rec updateflag vars body
muBlockToFunction bndr
cgTopRhsCon :: DataCon -> [StgArg] -> (MuBindInfo, MuCode ())
cgTopRhsCon con args = case args of
[] -> return () -- generate no code at all!
[StgLitArg (MachInt val)]
| maybeIntLikeCon con -> do
-- TODO: add more checks
muEmitTop $ ConstructorHeader (dataConName con)
muEmitTop $ LiteralInt (fromIntegral val)
[StgLitArg (MachChar val)]
| maybeCharLikeCon con -> do
-- TODO: add more checks
muEmitTop $ ConstructorHeader (dataConName con)
muEmitTop $ LiteralChar (fromIntegral (ord val))
_ -> void $ muEmitBlock $ toOL [MuStmt $ MuComment "StgRhsCon binding"]
-------------------------------------------------- Utilities
......@@ -156,6 +202,24 @@ closureBody name vars body = do
funcName = entryNameOf name
mucgExpr :: StgExpr -> MuCode ()
mucgExpr body = void $ case body of
StgApp fun args -> do
-- -- _ <- muEmitBlock $ toOL [MuStmt (MuComment "StgApp")]
-- -- _ <- muEmitBlock $ toOL [MuStmt (MuFunCall fun args)]
-- -- return ""
-- -- StgLit {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLit")]
-- -- StgConApp con args -> muEmitBlock $ toOL [MuStmt (MuComment "StgConApp")]
-- -- StgOpApp {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgOpApp")]
-- -- StgLam {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLam")]
-- -- StgCase scrut bndr alt_type alts -> do
-- -- mucgCase scrut bndr alt_type alts
-- -- return ""
-- -- StgLet {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLet")]
-- -- StgLetNoEscape {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLetNoEscape")]
-- -- StgTick {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgTick")]
-- | Bind some arguments from a closure to actual Mu values.
--
-- For this to work, there need to be at least as many values in the closure as
......@@ -229,10 +293,24 @@ mkClosure' target args = do
emit $ Store False Nothing muClosureFunction closFunctionField target Nothing
-- TODO: figure out the arity of this closure
return $ Return [clos]
-- TODO: populate the arguments
return $ Return [clos]
-- | Generate code for constructor applications at the top level.
cgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
cgTopRhsCon con bndr args = (info, code)
where
info = MuBindInfo bndr
get_lit arg =
seq (pprTraceIt "cgTopRhsCon" bndr) $
case arg of
StgVarArg var -> MuLabel var
StgLitArg lit ->
case cgLit lit of
MuLit l -> l
code = do
let payload = map get_lit args
emitGroup bndr [] (dataConWrapId con) payload
instance Show Var.Var where
......
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