WARNING! Access to this system is limited to authorised users only.
Unauthorised users may be subject to prosecution.
Unauthorised access to this system is a criminal offence under Australian law (Federal Crimes Act 1914 Part VIA)
It is a criminal offence to:
(1) Obtain access to data without authority. -Penalty 2 years imprisonment.
(2) Damage, delete, alter or insert data without authority. -Penalty 10 years imprisonment.
User activity is monitored and recorded. Anyone using this system expressly consents to such monitoring and recording.

To protect your data, the CISO officer has suggested users to enable 2FA as soon as possible.
Currently 2.6% of users enabled 2FA.

Commit d06055ae authored by Pavel Zakopaylo's avatar Pavel Zakopaylo
Browse files

Fixed bugs with main-function detection

Currently Zebu throws an error, but I suspect this is due to
a bug in the underlying `mu-client-ghc-api` library.
parent 7fa02e12
......@@ -256,7 +256,7 @@ data MuState = MuState
, _definitions :: Seq Definition
, _topLevels :: Seq TopLevel
, _topBinds :: M.Map GHC.Id GlobalCellName
, _mainFunc :: Maybe GHC.Id
, _mainFunc :: Maybe (VarName, VarName)
}
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 GHC.Id)
mainFunc :: Lens' MuState (Maybe (VarName, VarName))
mainFunc k m = fmap (\new -> m { _mainFunc = new }) (k (_mainFunc m))
-------------------------------------------------- * Block building monad
......@@ -428,10 +428,11 @@ upValue ctor ty = liftExpr $ do
-- | Extract the definitions and other useful things from the Mu monad.
bundleMu :: String -> Mu () -> MuResult
bundleMu modName codegen = runMu initialState $ do
-- XXX: Order is important
codegen
mainFunc <- haskellMain =<< gets _mainFunc
defns <- gets _definitions
tops <- gets _topLevels
mainFunc <- haskellMain =<< gets _mainFunc
return (defns, tops, mainFunc)
......@@ -442,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 GHC.Id -> Mu (Maybe FunctionName)
haskellMain name' = case name' of
haskellMain :: Maybe (VarName, VarName) -> Mu (Maybe FunctionName)
haskellMain m = case m of
Nothing -> return Nothing
Just name -> do
Just (entry, closure) -> do
typedef "@pi8" $ UPtr i8
typedef "@ppi8" $ UPtr "@pi8"
funcsig "@_haskell_main_sig" [i64, "@ppi8"] []
......@@ -455,8 +456,7 @@ haskellMain name' = case name' of
basicBlock "@_haskell_main.entry"
[("@_haskell_main.entry.argc", i64),
("@_haskell_main.entry.argv", "@ppi8")] $ do
return $ TailCall muClosureFunctionSig (entryNameOf' name)
[closureNameOf' name]
return $ TailCall muClosureFunctionSig entry [closure]
return $ Just "@_haskell_main"
......@@ -588,6 +588,9 @@ signatureNameOf n = case n of
dataConEntry :: (Uniquable a, NamedThing a) => a -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"
dataConEntry' :: (Uniquable a, NamedThing a) => a -> VarName
dataConEntry' n = VarName $ Name $ stringify n <> "_static_entry"
infoNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
infoNameOf n = GlobalCellName $ Name $ stringify n <> "_con_info"
......
......@@ -210,9 +210,9 @@ jumpToContinuation block result = do
codegenTop' :: GHC.Id -> StgRhs -> Mu ()
codegenTop' name rhs = do
mod <- gets _moduleName
when (tail (stringify name) == (mod <> "zdmain")) $ do
when (tail (stringify name) == ("zdmainzd" <> mod <> "zdmain")) $ do
traceM "Found main method!"
modify (\v -> v { _mainFunc = Just name })
modify (\v -> v { _mainFunc = Just (entry, closureNameOf' name) })
topBinds %= (M.insert name $ closureNameOf name)
case rhs of
......@@ -240,6 +240,12 @@ codegenTop' name rhs = do
[] -> [NullPointer] -- thunk, needs spot for indirection
l -> [] --function
where
entry = case rhs of
StgRhsCon _ con _ -> dataConEntry' con
StgRhsClosure {} -> entryNameOf' name
-- | Convert STG literal into primitive type
literal :: GHC.Id -> StgArg -> Mu UnboxedData
......
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