GitLab will be partched to the latest stable version on 15 July 2020 at 2.00pm (AEDT) to 2.30pm (AEDT) due to Security Patch Availability. During the update, GitLab and Mattermost services will not be available. If you have any concerns with this, please talk to us at N110 (b) CSIT building.

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