Ticket #7933: cmm_js.patch

File cmm_js.patch, 35.2 KB (added by bosu, 2 years ago)
  • compiler/deSugar/DsForeign.lhs

    diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
    index 9be8e96..2aa94ad 100644
    a b import Config 
    4848import OrdList
    4949import Pair
    5050import Util
     51import JsCodeGen (outputJoshInfos, JoshInfo(..))
    5152
    5253import Data.Maybe
    5354import Data.List
    dsFImport :: Id 
    129130          -> Coercion
    130131          -> ForeignImport
    131132          -> DsM ([Binding], SDoc, SDoc)
    132 dsFImport id co (CImport cconv safety mHeader spec) = do
     133dsFImport id co (CImport cconv safety' mHeader spec) = do
     134    dflags <- getDynFlags
     135    let safety = if hscTarget dflags == HscJavaScript then PlayRisky else safety'
    133136    (ids, h, c) <- dsCImport id co spec cconv safety mHeader
    134137    return (ids, h, c)
    135138
    dsFExport fn_id co ext_name cconv isDyn = do 
    358361                                Nothing                 -> (orig_res_ty, False)
    359362
    360363    dflags <- getDynFlags
    361     return $
    362       mkFExportCBits dflags ext_name
     364    return $ (if hscTarget dflags == HscJavaScript
     365                then mkFExportJSBits else mkFExportCBits)
     366             dflags ext_name
    363367                     (if isDyn then Nothing else Just fn_id)
    364368                     fe_arg_tys res_ty is_IO_res_ty cconv
    365369\end{code}
    dsFExportDynamic id co0 cconv = do 
    470474
    471475toCName :: DynFlags -> Id -> String
    472476toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
     477
     478-- list the arguments to the C function
     479argInfo :: DynFlags -> (Int -> SDoc -> SDoc) -> [Type]
     480            -> [(SDoc,           -- arg name
     481                SDoc,           -- C type
     482                Type,           -- Haskell type
     483                CmmType)]       -- the CmmType
     484argInfo dflags arg_cname arg_htys = [ let stg_type = showStgType ty in
     485                (arg_cname n stg_type,
     486                 stg_type,
     487                 ty,
     488                 typeCmmType dflags (getPrimTyOf ty))
     489              | (ty,n) <- zip arg_htys [1::Int ..] ]
     490
    473491\end{code}
    474492
    475493%*
    mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
    507525         -- use that instead.  I hope the two coincide --SDM
    508526    )
    509527 where
    510   -- list the arguments to the C function
    511   arg_info :: [(SDoc,           -- arg name
    512                 SDoc,           -- C type
    513                 Type,           -- Haskell type
    514                 CmmType)]       -- the CmmType
    515   arg_info  = [ let stg_type = showStgType ty in
    516                 (arg_cname n stg_type,
    517                  stg_type,
    518                  ty,
    519                  typeCmmType dflags (getPrimTyOf ty))
    520               | (ty,n) <- zip arg_htys [1::Int ..] ]
    521 
     528  arg_info = argInfo dflags arg_cname arg_htys
    522529  arg_cname n stg_ty
    523530        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
    524531                      ptext (sLit "args") <> brackets (int (n-1))
    mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
    650657     , rbrace
    651658     ]
    652659
     660mkFExportJSBits :: DynFlags
     661               -> FastString
     662               -> Maybe Id      -- Just==static, Nothing==dynamic
     663               -> [Type]
     664               -> Type
     665               -> Bool          -- True <=> returns an IO type
     666               -> CCallConv
     667               -> (SDoc,
     668                   SDoc,
     669                   String,      -- the argument reps
     670                   Int          -- total size of arguments
     671                  )
     672mkFExportJSBits dflags c_nm _ arg_htys res_hty is_IO_res_ty _
     673         = (empty, text (s_body ++ "\n" ++ josh_info), "ARGS", 0) where
     674    body = text "function " <> ftext c_nm <> parens fun_args <+> lbrace $$ vcat [
     675            text "var ret =" <+> ptext (sLit "rts_evalIO") <> parens (
     676                ptext (sLit "rts_apply") <> parens (
     677                 ptext (sLit run_io)
     678                 <> comma
     679                 <> expr_to_run
     680                )) <> semi
     681            , return_result
     682            , rbrace <> text "\n"
     683            ]
     684    run_io = "base_GHCziTopHandler_run" ++ (if is_IO_res_ty then "" else "Non") ++ "IO_closure"
     685    s_body = showSDoc dflags body
     686    s_name = unpackFS c_nm
     687    josh_info = outputJoshInfos [ JoshInfo s_name 0 lin [] [ run_io, "stg_forceIO_info" ] ]
     688                                    (lin + 1)
     689    lin = fromIntegral $ length s_body
     690    fun_args = hsep $ punctuate comma $ cfun:(map (\(nm,_,_,_) -> nm) arg_info)
     691    cfun = text "prev"
     692    arg_info = argInfo dflags (\n _ -> text ('a':show n)) arg_htys
     693    expr_to_run = foldl app_arg cfun arg_info where
     694          app_arg acc (arg_cname, _, arg_hty, _)
     695             = text "rts_apply"
     696               <> parens (acc <> comma <> mkHObj arg_hty <> parens (arg_cname))
     697    return_result | res_hty `eqType` unitTy = empty
     698                  | otherwise = text "return" <+> unpackHObj res_hty
     699                                                <> parens (text "ret") <> semi
    653700
    654701foreignExportInitialiser :: Id -> SDoc
    655702foreignExportInitialiser hs_fn =
  • compiler/ghc.cabal.in

    diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
    index 90a241f..1e9c43b 100644
    a b Library 
    113113        llvmGen
    114114        main
    115115        nativeGen
     116        jsGen
    116117        parser
    117118        prelude
    118119        profiling
    Library 
    463464
    464465    Exposed-Modules:
    465466            AsmCodeGen
     467            JsCodeGen
     468            PointerMarker
     469            JsTransforms
    466470            TargetReg
    467471            NCGMonad
    468472            Instruction
  • new file compiler/jsGen/JsCodeGen.hs

    diff --git a/compiler/jsGen/JsCodeGen.hs b/compiler/jsGen/JsCodeGen.hs
    new file mode 100644
    index 0000000..a5a3264
    - +  
     1{-# LANGUAGE GADTs #-}
     2{-# OPTIONS_GHC -Werror #-}
     3module JsCodeGen (jsCodeGen, outputJoshInfos, JoshInfo(..)) where
     4
     5import Stream (Stream, collect)
     6import Cmm
     7import CLabel (CLabel, externallyVisibleCLabel)
     8import DynFlags
     9import BlockId
     10import Hoopl
     11import CmmUtils
     12import PprCmm ()
     13import Data.List (intercalate)
     14import Control.Monad.Trans.State
     15import Control.Monad.IO.Class (liftIO)
     16import System.IO
     17import qualified Data.Set as S
     18import Data.Maybe
     19import qualified Data.Map as M
     20import Control.Monad (when)
     21import PointerMarker
     22import UniqSupply
     23import Data.Bits
     24import JsTransforms
     25
     26data JoshInfo = JoshInfo String Integer Integer [String] [String]
     27data St = St { sNest :: Int, sHandle :: Handle, sDecls :: [JoshInfo]
     28                    , sCurRegs :: S.Set String, sCurCalls :: S.Set String
     29                    , sDynFlags :: DynFlags
     30                    , sCurBlockMap :: M.Map Label Int, sCurPrefix :: String }
     31type MIO = StateT St IO
     32type Decl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) CmmGraph
     33
     34modNest :: (Int -> Int -> Int) -> MIO ()
     35modNest op = modify go where
     36    go s = s { sNest = sNest s `op` 1 }
     37
     38nest :: MIO () -> MIO ()
     39nest more = modNest (+) >> more >> modNest (-)
     40
     41emit :: String -> MIO ()
     42emit str = do
     43    s <- get
     44    liftIO $ hPutStrLn (sHandle s) $ (replicate (sNest s) '\t') ++ str
     45
     46infoLabel :: Decl -> (CLabel, [CmmStatic]);
     47infoLabel (CmmData _ (Statics l d)) = (l, d)
     48infoLabel (CmmProc h l _ g) = case mapLookup (g_entry g) h of
     49                          Nothing                   -> (l, [])
     50                          Just (Statics info_lbl d) -> (info_lbl, d)
     51
     52withJosh :: String -> MIO () -> MIO ()
     53withJosh fn more = do
     54    st <- get
     55    begin <- liftIO $ hTell $ sHandle st
     56    more
     57    end <- liftIO $ hTell $ sHandle st
     58    flush_info fn begin end
     59    where flush_info n begin end = do
     60            st <- get
     61            let regs = S.toList $ sCurRegs st
     62            let calls = S.toList $ sCurCalls st
     63            put $ st { sDecls = (JoshInfo n begin end regs calls):(sDecls st)
     64                            , sCurRegs = S.empty, sCurCalls = S.empty }
     65
     66compileStatics :: String -> String -> [CmmStatic] -> MIO ()
     67compileStatics fn fin ss = case ss of
     68    ((CmmString s):_) -> em $ "i8_heap(" ++ show s ++ ")"
     69    _ -> do syms <- mapM go ss
     70            em $ "heap([ " ++ (intercalate ", " syms) ++ fin
     71    where go (CmmStaticLit s) = fmap snd $ compileExpr False $ CmmLit s
     72          go (CmmUninitialised 4) = return "0"
     73          go s = do dflags <- gets sDynFlags
     74                    return $ "undefined /* " ++ toString dflags s ++ " */"
     75          em ics = emit $ unlines [
     76                        "var V" ++ fn ++ ";"
     77                        , "function " ++ fn ++ "() {"
     78                        , "\tif (!V" ++ fn ++ ")"
     79                        , "\t\tV" ++ fn ++ " = " ++ ics ++ ";"
     80                        , "\treturn V" ++ fn ++ ".apply(this, arguments);"
     81                        , "}" ]
     82
     83compileDecl :: DynFlags -> Decl -> MIO ()
     84compileDecl _ (CmmData _ (Statics l d)) = do
     85    vn <- jsFuncName l
     86    withJosh vn $ compileStatics vn " ], 0)" d
     87compileDecl dflags p@(CmmProc _ _ _ g) = do
     88    us <- liftIO $ mkSplitUniqSupply 'Q'
     89
     90    let blocks = toBlockListEntryFirst $ markPointers dflags us $ jsTransform dflags g
     91    let bmap = M.fromList $ zip (map entryLabel blocks) [ 0 .. ]
     92
     93    modify ( \s -> s { sCurBlockMap = bmap } )
     94    withinFunction (infoLabel p) $ do
     95        emit $ "var label = 0;"
     96        emit $ "for (;;) {"
     97        emit $ "switch (label) {"
     98        mapM_ doBlock blocks
     99        emit $ "} }"
     100    where doBlock block = do
     101            let (CmmEntry cid, nodes, tail)  = blockSplit block
     102            clab <- blockLookup cid
     103            let stmts = blockToList nodes
     104            emit $ "case " ++ clab ++ ":"
     105            nest $ do
     106                mapM_ (compileCmmNode dflags) stmts
     107                compileTail tail
     108                emit "break;"
     109
     110withinFunction :: (CLabel, [CmmStatic]) -> MIO () -> MIO ()
     111withinFunction (lab, ss) more = do
     112    fn <- jsFuncName lab
     113    withJosh fn $ do
     114        case ss of
     115            [] -> emfu fn
     116            _ -> do emfu ('_':fn)
     117                    dflags <- gets sDynFlags
     118                    let func_off = show $ wORD_SIZE dflags * length ss
     119                    compileStatics fn (", _" ++ fn ++ " ], " ++ func_off ++ ")") ss
     120    where emfu fn = do emit $ "function " ++ fn ++ "() {"
     121                       nest more
     122                       emit "}"
     123
     124jsFuncName :: CLabel -> MIO String
     125jsFuncName l = do
     126    dn <- gets sCurPrefix
     127    dflags <- gets sDynFlags
     128    let s = toString dflags l
     129    if externallyVisibleCLabel l
     130        then return s
     131        else return $ dn ++ "_" ++ s
     132
     133withCurrentPrefix :: MIO () -> [Decl] -> MIO ()
     134withCurrentPrefix next decls = maybe (return ()) go $ listToMaybe ns where
     135    go dn = do dflags <- gets sDynFlags
     136               modify (\s -> s { sCurPrefix = toString dflags dn }) >> next
     137    ns = filter externallyVisibleCLabel $ map fst $ map infoLabel decls
     138
     139emitRawCmmGroup :: DynFlags -> [Decl] -> MIO ()
     140emitRawCmmGroup dflags = mapM_ (compileDecl dflags)
     141
     142outputJoshInfos :: [JoshInfo] -> Integer -> String
     143outputJoshInfos is cur = unlines [
     144        "/* --josh-- ["
     145        , intercalate ", " $ map (go cur) is
     146        , "] --josh-- */" ]
     147    where go cur (JoshInfo name begin end regs calls) = unlines [
     148            "{", "\"name\": \"" ++ name ++ "\","
     149            , "\"offset\": " ++ show (cur - begin) ++ ","
     150            , "\"length\": " ++ show (end - begin) ++ ","
     151            , "\"calls\": " ++ show calls ++ ","
     152            , "\"regs\": " ++ show regs
     153            , "}" ]
     154
     155jsCodeGen :: DynFlags -> String -> Stream IO RawCmmGroup () -> IO ()
     156jsCodeGen dflags fname cmm_stream = do
     157    raws :: [RawCmmGroup] <- collect cmm_stream
     158    withFile fname WriteMode $ \h -> evalStateT (withCurrentPrefix (go raws) $ concat raws)
     159                $ St 0 h [] S.empty S.empty dflags M.empty ""
     160    where go raws = do mapM_ (emitRawCmmGroup dflags) raws
     161                       st <- get
     162                       cur <- liftIO $ hTell (sHandle st)
     163                       liftIO $ hPutStrLn (sHandle st) $ outputJoshInfos (sDecls st) cur
     164
     165showLabel :: CLabel -> MIO (Bool, String)
     166showLabel l = do
     167    n <- jsFuncName l
     168    modify (calls n)
     169    return (True, n)
     170    where calls n st = st { sCurCalls = S.insert n (sCurCalls st) }
     171
     172recordReg :: CmmReg -> MIO String
     173recordReg r = do
     174    dflags <- gets sDynFlags
     175    case r of
     176        (CmmLocal (LocalReg u _)) -> return $ "v" ++ toString dflags u
     177        _ -> do let res = toString dflags r
     178                modify (\st -> st { sCurRegs = S.insert res (sCurRegs st) })
     179                return res
     180
     181ptrOff :: String -> Int -> (Bool, String)
     182ptrOff s i = (True, s ++ "(OP_ADD, " ++ show i ++ ")")
     183
     184scalar :: Bool -> String -> String
     185scalar is_ptr se = if is_ptr then se ++ "(OP_PTR)" else se
     186
     187compileExpr :: Bool -> CmmExpr -> MIO (Bool, String)
     188compileExpr _ (CmmLit lit) = case lit of
     189    CmmLabelOff l i -> do
     190        s <- showLabel l
     191        return $ ptrOff (snd s) i
     192    CmmLabel l -> showLabel l
     193    CmmInt i w -> return (False, show_i i w)
     194    _ -> do
     195        dflags <- gets sDynFlags
     196        return $ (False, "0 /* " ++ toString dflags lit ++ " */")
     197    where show_i i W64 = "[ " ++ show (i .&. 0xffffffff) ++ ", " ++ show (i `shiftR` 32) ++ " ]"
     198          show_i i _ = show i
     199
     200compileExpr b (CmmRegOff reg i) = do
     201    (is_ptr, str) <- compileExpr b (CmmReg reg)
     202    return $ if is_ptr then ptrOff str i else plus str
     203    where plus str = (False, "(" ++ str ++ " + " ++ show i ++ ")")
     204
     205compileExpr b (CmmLoad expr t) = do
     206    (_, res) <- compileExpr True expr
     207    dflags <- gets sDynFlags
     208    return (b || isGcPtrType t, res ++ "(OP_LOAD_" ++ (toString dflags $ typeWidth t) ++ ")")
     209
     210compileExpr b o@(CmmMachOp op es) = do
     211    ((is_ptr, h):hs) <- fmap ptr_first $ mapM (compileExpr False) es
     212    let ptr_op s = (True, h ++ "(" ++ intercalate ", " (s:map snd hs) ++ ")")
     213    let scal_op sca s = (False, "(" ++ (intercalate s $ (sca is_ptr h):map snd hs) ++ ")")
     214    dflags <- gets sDynFlags
     215    return $ case (b || is_ptr, op) of
     216        (True, MO_Add _) -> ptr_op "OP_ADD"
     217        (True, MO_Sub _) -> ptr_op "OP_SUB"
     218        (True, MO_And _) -> ptr_op "OP_AND"
     219        (True, MO_Or _) -> ptr_op "OP_OR"
     220        (True, MO_U_Shr _) -> ptr_op "OP_SHR"
     221        (True, MO_Ne _) -> scal_op (const maybeptr) " !== "
     222        (True, MO_Eq _) -> scal_op (const maybeptr) " === "
     223        (_, MO_Add _) -> scal_op scalar " + "
     224        (_, MO_Ne _) -> scal_op scalar " != "
     225        (_, MO_Eq _) -> scal_op scalar " == "
     226        (_, MO_Sub _) -> scal_op scalar " - "
     227        (_, MO_Mul _) -> scal_op scalar " * "
     228        (_, MO_S_Lt _) -> scal_op scalar " < "
     229        (_, MO_U_Lt _) -> scal_op scalar " < "
     230        (_, MO_S_Gt _) -> scal_op scalar " > "
     231        (_, MO_U_Gt _) -> scal_op scalar " > "
     232        (_, MO_S_Ge _) -> scal_op scalar " >= "
     233        (_, MO_U_Ge _) -> scal_op scalar " >= "
     234        (_, MO_S_Le _) -> scal_op scalar " <= "
     235        (_, MO_U_Le _) -> scal_op scalar " <= "
     236        (_, MO_And _) -> scal_op scalar " & "
     237        (_, MO_Or _) -> scal_op scalar " | "
     238        (_, MO_Shl _) -> scal_op scalar " << "
     239        (_, MO_S_Rem _) -> scal_op scalar " % "
     240        (_, MO_S_Quot _) -> scal_op scalar " / " -- TODO: float to int in JS
     241        (_, MO_Xor _) -> scal_op scalar " ^ "
     242        (_, MO_U_Shr _) -> scal_op scalar " >> "
     243        (_, MO_S_Shr _) -> scal_op scalar " >> "
     244        (_, MO_SS_Conv _ _) -> (is_ptr, h)
     245        (_, MO_UU_Conv _ _) -> (is_ptr, h)
     246        (_, MO_S_Neg _) -> (False, "(-" ++ h ++ (if is_ptr then "(OP_PTR)" else "") ++ ")")
     247        _ -> (is_ptr, " noop(" ++ show is_ptr ++ ", " ++ toString dflags o ++ ")")
     248    where ptr_first l = case break fst l of
     249                                (xs, []) -> xs
     250                                (xs, x:ys) -> x:(xs ++ ys)
     251          maybeptr h = case es of
     252                        [ (CmmLit (CmmInt _ _)), _ ] -> scalar True h
     253                        [ _, (CmmLit (CmmInt _ _)) ] -> scalar True h
     254                        _ -> h
     255
     256compileExpr b (CmmReg r) = do
     257    dflags <- gets sDynFlags
     258    res <- recordReg r
     259    return (b || (isGcPtrType $ cmmRegType dflags r) || r == CmmGlobal Sp, res)
     260
     261compileExpr _ e = do
     262    dflags <- gets sDynFlags
     263    return (False, toString dflags e)
     264
     265compileCmmNode :: DynFlags -> CmmNode O O -> MIO ()
     266compileCmmNode dflags (CmmStore r e) = do
     267    (_, re) <- compileExpr True r
     268    (_, se) <- compileExpr False e
     269    emit $ re ++ "(OP_STORE_" ++ w ++ ", " ++ se ++ ")" ++ ";"
     270    where w = toString dflags $ typeWidth $ cmmExprType dflags e
     271
     272compileCmmNode dflags (CmmAssign target e) = do
     273    r <- recordReg target
     274    (_, se) <- compileExpr False e
     275    when (target == CmmGlobal Hp) $ emit $ "Hp = heap([], -4);"
     276    emit $ r ++ " = " ++ go se (isGcPtrType $ cmmRegType dflags target) e ++ ";"
     277                        -- ++ " /* " ++ toString dflags c ++ " */"
     278    where go se True (CmmLit (CmmInt _ _)) = "heap([], " ++ se ++ ")"
     279          go se _ _ = se
     280
     281compileCmmNode _ (CmmComment _) = return ()
     282compileCmmNode _ (CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _) = return ()
     283compileCmmNode dflags (CmmUnsafeForeignCall (ForeignTarget ex _) res args) = do
     284    as <- mapM (compileExpr False) args
     285    (_, c) <- compileExpr False ex
     286    r <- get_res
     287    emit $ r ++ c ++ "(" ++ (intercalate ", " $ map snd as) ++ ");"
     288    where get_res = case res of
     289            [] -> return ""
     290            (x:[]) -> do r <- recordReg (CmmLocal x)
     291                         return $ "var " ++ r ++ " = "
     292            more -> return $ "Unhandled Foreign Call: " ++ toString dflags more
     293
     294compileCmmNode dflags st = emit $ "compileCmmNode: " ++ toString dflags st
     295
     296blockLookup :: Label -> MIO String
     297blockLookup l = do
     298    bmap <- gets sCurBlockMap
     299    return $ show $ fromJust $ M.lookup l bmap
     300
     301compileTail :: CmmNode O C -> MIO ()
     302compileTail (CmmCondBranch b true false) = do
     303    (is_ptr, se) <- compileExpr False b
     304    tid <- blockLookup true
     305    fid <- blockLookup false
     306    emit $ "label = (" ++ scalar is_ptr se ++ ") ? " ++ tid ++ " : " ++ fid ++ ";"
     307compileTail (CmmCall expr _ _ _ _ _) = do
     308    (_, se) <- compileExpr False expr
     309    emit $ "return " ++ se ++ ";"
     310compileTail (CmmBranch lb) = do
     311    bid <- blockLookup lb
     312    emit $ "label = " ++ bid ++ ";"
     313
     314compileTail (CmmSwitch expr labs) = do
     315    (is_ptr, se) <- compileExpr False expr
     316    emit $ "switch (" ++ scalar is_ptr se ++ ") {"
     317    mapM_ cas $ zip [ 0 .. ] labs
     318    emit $ "}"
     319    where cas :: (Int, Maybe Label) -> MIO ()
     320          cas (i, Nothing) = emit $ "case " ++ show i ++ ":"
     321          cas (i, Just l) = do
     322            to <- blockLookup l
     323            emit $ "case " ++ show i ++ ":"
     324            nest $ do
     325                emit $ "label = " ++ to ++ ";"
     326                emit "break;"
     327compileTail tail = do
     328    dflags <- gets sDynFlags
     329    emit $ "Tail: " ++ toString dflags tail
     330
  • new file compiler/jsGen/JsTransforms.hs

    diff --git a/compiler/jsGen/JsTransforms.hs b/compiler/jsGen/JsTransforms.hs
    new file mode 100644
    index 0000000..95c9b62
    - +  
     1{-# LANGUAGE GADTs #-}
     2{-# OPTIONS_GHC -Werror #-}
     3module JsTransforms (jsTransform) where
     4
     5import DynFlags
     6import Cmm
     7import CmmUtils
     8import FastString
     9import PointerMarker
     10
     11removeMemorySafeGuards :: CmmGraph -> CmmGraph
     12removeMemorySafeGuards = mapGraphNodes1 (mapExpDeep go)
     13    where go (CmmMachOp (MO_U_Gt w) [ CmmReg (CmmGlobal Hp), CmmReg (CmmGlobal HpLim)]) =
     14                CmmLit (CmmInt 0 w)
     15          go (CmmMachOp (MO_U_Lt w) [ _, CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 w)
     16          go expr = expr
     17
     18-- Ideally we would rewrite to CmmBranch false, but multiple rewrites interfere with
     19-- each other here. Investigate it.
     20noLargeAllocLimit :: DynFlags -> CmmGraph -> CmmGraph
     21noLargeAllocLimit dflags = mapGraphNodes (id, id, go)
     22    where go (CmmCondBranch oex@(CmmMachOp (MO_U_Ge w) [ CmmLoad ex _, _ ]) true false) =
     23                CmmCondBranch nex true false
     24                where nex = case ex of
     25                        CmmMachOp (MO_Add _) [ CmmLoad (CmmLit (CmmLabel lbl)) _, _ ]
     26                            -> if toString dflags lbl == "g0" then (CmmLit (CmmInt 0 w))
     27                                                              else oex
     28                        _ -> oex
     29          go cn = cn
     30
     31simplifyCondBranches :: CmmGraph -> CmmGraph
     32simplifyCondBranches = mapGraphNodes1 go
     33    where go (CmmCondBranch (CmmMachOp (MO_Eq w) [ (CmmLoad
     34                    (CmmMachOp _ [ CmmReg (CmmGlobal CurrentNursery), _]) _)
     35                        , (CmmLit (CmmInt 0 _))]) true false)
     36                = CmmCondBranch (CmmLit (CmmInt 0 w)) true false
     37          go (CmmStore (CmmRegOff (CmmGlobal CurrentNursery) 4) (CmmRegOff (CmmGlobal Hp) 4))
     38                = CmmComment $ fsLit "CurrentNursery Hp store"
     39          go (CmmAssign (CmmGlobal SpLim) _) = CmmComment $ fsLit $ "SpLim assign"
     40          go (CmmAssign (CmmGlobal HpAlloc) _) = CmmComment $ fsLit $ "HpAlloc assign"
     41          go (CmmAssign (CmmGlobal HpLim) _) = CmmComment $ fsLit $ "HpLim assign"
     42          go (CmmAssign (CmmGlobal Hp) (CmmMachOp _ ((CmmLoad
     43                    (CmmRegOff (CmmGlobal CurrentNursery) 4) _):_)))
     44                = CmmComment $ fsLit $ "CurrentNursery Hp load"
     45          go cn = cn
     46
     47jsTransform :: DynFlags -> CmmGraph -> CmmGraph
     48jsTransform dflags = noLargeAllocLimit dflags . simplifyCondBranches . removeMemorySafeGuards
  • new file compiler/jsGen/PointerMarker.hs

    diff --git a/compiler/jsGen/PointerMarker.hs b/compiler/jsGen/PointerMarker.hs
    new file mode 100644
    index 0000000..ee91a04
    - +  
     1{-# LANGUAGE GADTs #-}
     2module PointerMarker(markPointers, toString) where
     3
     4import DynFlags
     5import UniqSupply
     6import Cmm
     7import CmmUtils
     8import qualified Data.Set as S
     9import Hoopl
     10import Compiler.Hoopl (mkLast, mkMiddle)
     11import PprCmm ()
     12import Outputable
     13
     14type LoadStores = S.Set CmmReg
     15
     16toString :: Outputable a => DynFlags -> a -> String
     17toString dflags l = renderWithStyle dflags (ppr l) $ mkCodeStyle CStyle
     18
     19markPointers :: DynFlags -> UniqSupply -> CmmGraph -> CmmGraph
     20markPointers dflags us g = initUs_ us $ markFromLoadStores dflags g >>= markFromPreviousUsage dflags
     21
     22loadStoreLattice :: DataflowLattice LoadStores
     23loadStoreLattice = DataflowLattice "Track load stores" S.empty add
     24    where add _ (OldFact old) (NewFact new) =
     25               (changeIf $ S.size join > S.size old, join)
     26              where !join = S.union old new
     27
     28findRegs :: (CmmReg -> LoadStores -> LoadStores) -> CmmExpr -> LoadStores -> LoadStores
     29findRegs ins (CmmMachOp _ (e:_)) f = findRegs ins e f
     30findRegs ins ex f = wrapRecExpf go ex f
     31    where go (CmmReg r) s = ins r s
     32          go (CmmRegOff r _) s = ins r s
     33          go _ s = s
     34
     35findLoad :: CmmExpr -> LoadStores -> LoadStores
     36findLoad (CmmLoad e _) f = findRegs S.insert e f
     37findLoad _ f = f
     38
     39xferLoadStores :: BwdTransfer CmmNode LoadStores
     40xferLoadStores = mkBTransfer3 first mid lst
     41  where first _ f = f
     42        mid :: CmmNode O O -> LoadStores -> LoadStores
     43        mid (CmmStore r e) f = findLoad e $ findRegs S.insert r f
     44        mid n f = foldExpDeep findLoad n f
     45
     46        lst :: CmmNode O C -> FactBase LoadStores -> LoadStores
     47        lst n f = foldExpDeep findLoad n $ joinOutFacts loadStoreLattice n f
     48
     49setPointerType :: DynFlags -> LoadStores -> CmmReg -> CmmReg
     50setPointerType dflags ls r = go (S.member r ls) r where
     51    go True (CmmLocal (LocalReg u _)) = CmmLocal $ LocalReg u $ gcWord dflags
     52    go True (CmmGlobal (VanillaReg u _)) = CmmGlobal $ VanillaReg u VGcPtr
     53    go _ reg = reg
     54
     55pointerReplace :: DynFlags -> LoadStores -> CmmExpr -> CmmExpr
     56pointerReplace dflags ls (CmmReg r) = CmmReg $ setPointerType dflags ls r
     57pointerReplace dflags ls (CmmRegOff r o) = CmmRegOff (setPointerType dflags ls r) o
     58pointerReplace _ _ e = e
     59
     60middleProp :: DynFlags -> (LoadStores -> CmmNode O O -> CmmNode O O)
     61                -> CmmNode O O -> LoadStores -> UniqSM (Maybe (Graph CmmNode O O))
     62middleProp dflags cb n f = return $ Just $ mkMiddle $ cb f $ mapExpDeep (pointerReplace dflags f) n
     63 
     64pointerProp :: DynFlags -> BwdRewrite UniqSM CmmNode LoadStores
     65pointerProp dflags = mkBRewrite3 first (middleProp dflags mid) last
     66    where first _ _ = return Nothing
     67
     68          mid f (CmmAssign r e) = CmmAssign (setPointerType dflags f r) e
     69          mid _ o = o
     70         
     71          last :: CmmNode O C -> FactBase LoadStores -> UniqSM (Maybe (Graph CmmNode O C))
     72          last n fb = return $ Just $ mkLast $ mapExpDeep (pointerReplace dflags s) n
     73            where s = mapFold S.union S.empty fb
     74
     75markFromLoadStores :: DynFlags -> CmmGraph -> UniqSM CmmGraph
     76markFromLoadStores dflags g = fmap fst $ dataflowPassBwd g []
     77    $ analRewBwd loadStoreLattice xferLoadStores (pointerProp dflags)
     78
     79insPointer :: DynFlags -> CmmReg -> LoadStores -> LoadStores
     80insPointer dflags r s = if b then S.insert r s else s
     81    where b = isGcPtrType $ cmmRegType dflags r
     82
     83xferPreviousUsage :: DynFlags -> FwdTransfer CmmNode LoadStores
     84xferPreviousUsage dflags = mkFTransfer3 first mid lst
     85    where first _ f = f
     86          mid :: CmmNode O O -> LoadStores -> LoadStores
     87          mid n f = case n of
     88            CmmAssign r _ -> if isGcPtrType $ cmmRegType dflags r
     89                then S.insert r s
     90                else S.delete r s
     91            _ -> s
     92            where s = foldExpDeep (findRegs (insPointer dflags)) n f
     93
     94          lst :: CmmNode O C -> LoadStores -> FactBase LoadStores
     95          lst l x = mkFactBase loadStoreLattice $ map (\id -> (id, s)) (successors l)
     96            where s = foldExpDeep (findRegs (insPointer dflags)) l x
     97
     98usageProp :: DynFlags -> FwdRewrite UniqSM CmmNode LoadStores
     99usageProp dflags = mkFRewrite3 first (middleProp dflags (const id)) last
     100    where first _ _ = return Nothing
     101          last :: CmmNode O C -> LoadStores -> UniqSM (Maybe (Graph CmmNode O C))
     102          last n f = return $ Just $ mkLast $ mapExpDeep (pointerReplace dflags f) n
     103
     104markFromPreviousUsage :: DynFlags -> CmmGraph -> UniqSM CmmGraph
     105markFromPreviousUsage dflags g = fmap fst $ dataflowPassFwd g []
     106    $ analRewFwd loadStoreLattice (xferPreviousUsage dflags) (usageProp dflags)
  • compiler/main/CodeOutput.lhs

    diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
    index f940303..47ca73d 100644
    a b module CodeOutput( codeOutput, outputForeignStubs ) where 
    1010
    1111import AsmCodeGen ( nativeCodeGen )
    1212import LlvmCodeGen ( llvmCodeGen )
     13import JsCodeGen ( jsCodeGen )
    1314
    1415import UniqSupply       ( mkSplitUniqSupply )
    1516
    codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream 
    7879             HscAsm         -> outputAsm dflags this_mod filenm linted_cmm_stream;
    7980             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
    8081             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
     82             HscJavaScript  -> jsCodeGen dflags filenm linted_cmm_stream;
    8183             HscInterpreted -> panic "codeOutput: HscInterpreted";
    8284             HscNothing     -> panic "codeOutput: HscNothing"
    8385          }
    outputForeignStubs dflags mod location stubs 
    224226            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
    225227                         | otherwise = ""
    226228
     229            c_header | hscTarget dflags == HscJavaScript = ""
     230
     231                     -- We're adding the default hc_header to the stub file, but this
     232                     -- isn't really HC code, so we need to define IN_STG_CODE==0 to
     233                     -- avoid the register variables etc. being enabled.
     234                     | otherwise = "#define IN_STG_CODE 0\n" ++
     235                                         "#include \"Rts.h\"\n" ++
     236                                         rts_includes ++
     237                                         ffi_includes ++
     238                                         cplusplus_hdr
    227239        stub_h_file_exists
    228240           <- outputForeignStubs_help stub_h stub_h_output_w
    229241                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
    outputForeignStubs dflags mod location stubs 
    233245
    234246        stub_c_file_exists
    235247           <- outputForeignStubs_help stub_c stub_c_output_w
    236                 ("#define IN_STG_CODE 0\n" ++
    237                  "#include \"Rts.h\"\n" ++
    238                  rts_includes ++
    239                  ffi_includes ++
    240                  cplusplus_hdr)
     248                 c_header
    241249                 cplusplus_ftr
    242            -- We're adding the default hc_header to the stub file, but this
    243            -- isn't really HC code, so we need to define IN_STG_CODE==0 to
    244            -- avoid the register variables etc. being enabled.
    245 
    246250        return (stub_h_file_exists, if stub_c_file_exists
    247251                                       then Just stub_c
    248252                                       else Nothing )
    249253 where
    250254   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
    251    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
     255   cplusplus_ftr | hscTarget dflags == HscJavaScript = ""
     256                 | otherwise = "#ifdef __cplusplus\n}\n#endif\n"
    252257
    253258
    254259-- Don't use doOutput for dumping the f. export stubs
  • compiler/main/DriverPipeline.hs

    diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
    index 7df823c..a610e9f 100644
    a b runPhase (RealPhase Splitter) input_fn dflags 
    12321232
    12331233-- This is for calling the assembler on a regular assembly file (not split).
    12341234runPhase (RealPhase As) input_fn dflags
    1235   = do
     1235  | hscTarget dflags == HscJavaScript = do
     1236              next_phase <- maybeMergeStub
     1237              output_fn <- phaseOutputFilename next_phase
     1238              liftIO $ copyFile input_fn output_fn
     1239              return (RealPhase next_phase, output_fn)
     1240  | otherwise = do
    12361241        -- LLVM from version 3.0 onwards doesn't support the OS X system
    12371242        -- assembler, so we use clang as the assembler instead. (#5636)
    12381243        let whichAsProg | hscTarget dflags == HscLlvm &&
    getHCFilePackages filename = 
    17441749      _other ->
    17451750          return []
    17461751
     1752mkExtraLinkObjects :: DynFlags -> [PackageId] -> IO [FilePath]
     1753mkExtraLinkObjects dflags dep_packages
     1754    | hscTarget dflags == HscJavaScript = return []
     1755    | otherwise = do
     1756            extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
     1757            noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
     1758            return $ extraLinkObj:noteLinkObjs
     1759
     1760
    17471761-----------------------------------------------------------------------------
    17481762-- Static linking, of .o files
    17491763
    linkBinary dflags o_files dep_packages = do 
    18001814    let lib_paths = libraryPaths dflags
    18011815    let lib_path_opts = map ("-L"++) lib_paths
    18021816
    1803     extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
    1804     noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
    1805 
     1817    extraObjs <- mkExtraLinkObjects dflags dep_packages
    18061818    pkg_link_opts <- if platformBinariesAreStaticLibs platform
    18071819                     then -- If building an executable really means
    18081820                          -- making a static library (e.g. iOS), then
    linkBinary dflags o_files dep_packages = do 
    19111923                      ++ framework_path_opts
    19121924                      ++ framework_opts
    19131925                      ++ pkg_lib_path_opts
    1914                       ++ extraLinkObj:noteLinkObjs
     1926                      ++ extraObjs
    19151927                      ++ pkg_link_opts
    19161928                      ++ pkg_framework_path_opts
    19171929                      ++ pkg_framework_opts
    getBackendDefs dflags | hscTarget dflags == HscLlvm = do 
    20622074    llvmVer <- figureLlvmVersion dflags
    20632075    return [ "-D__GLASGOW_HASKELL_LLVM__="++show llvmVer ]
    20642076
     2077getBackendDefs dflags | hscTarget dflags == HscJavaScript = do
     2078    return [ "-DJAVASCRIPT" ]
     2079
    20652080getBackendDefs _ =
    20662081    return []
    20672082
    hscPostBackendPhase dflags _ hsc_lang = 
    21262141        HscAsm | gopt Opt_SplitObjs dflags -> Splitter
    21272142               | otherwise                 -> As
    21282143        HscLlvm        -> LlvmOpt
     2144        HscJavaScript  -> As
    21292145        HscNothing     -> StopLn
    21302146        HscInterpreted -> StopLn
    21312147
  • compiler/main/DynFlags.hs

    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index f206095..bc39395 100644
    a b data HscTarget 
    890890  = HscC           -- ^ Generate C code.
    891891  | HscAsm         -- ^ Generate assembly using the native code generator.
    892892  | HscLlvm        -- ^ Generate assembly using the llvm code generator.
     893  | HscJavaScript  -- ^ Generate JavaScript.
    893894  | HscInterpreted -- ^ Generate bytecode.  (Requires 'LinkInMemory')
    894895  | HscNothing     -- ^ Don't generate any code.  See notes above.
    895896  deriving (Eq, Show)
    isObjectTarget :: HscTarget -> Bool 
    899900isObjectTarget HscC     = True
    900901isObjectTarget HscAsm   = True
    901902isObjectTarget HscLlvm  = True
     903isObjectTarget HscJavaScript  = True
    902904isObjectTarget _        = False
    903905
    904906-- | Does this target retain *all* top-level bindings for a module,
    dynamic_flags = [ 
    23072309  , Flag "fvia-C"           (NoArg
    23082310         (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release"))
    23092311  , Flag "fllvm"            (NoArg (setObjTarget HscLlvm))
     2312  , Flag "fjavascript"            (NoArg (setObjTarget HscJavaScript))
    23102313
    23112314  , Flag "fno-code"         (NoArg (do upd $ \d -> d{ ghcLink=NoLink }
    23122315                                       setTarget HscNothing))
  • compiler/typecheck/TcForeign.lhs

    diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
    index 630157e..af01062 100644
    a b checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc 
    427427checkCOrAsmOrLlvm HscC    = Nothing
    428428checkCOrAsmOrLlvm HscAsm  = Nothing
    429429checkCOrAsmOrLlvm HscLlvm = Nothing
     430checkCOrAsmOrLlvm HscJavaScript  = Nothing
    430431checkCOrAsmOrLlvm _
    431432  = Just (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
    432433
    checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc 
    434435checkCOrAsmOrLlvmOrInterp HscC           = Nothing
    435436checkCOrAsmOrLlvmOrInterp HscAsm         = Nothing
    436437checkCOrAsmOrLlvmOrInterp HscLlvm        = Nothing
     438checkCOrAsmOrLlvmOrInterp HscJavaScript  = Nothing
    437439checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
    438440checkCOrAsmOrLlvmOrInterp _
    439441  = Just (text "requires interpreted, unregisterised, llvm or native code generation")
  • includes/Cmm.h

    diff --git a/includes/Cmm.h b/includes/Cmm.h
    index 89baaa0..1c79ab4 100644
    a b  
    408408   HP_CHK_P(bytes);                             \
    409409   TICK_ALLOC_HEAP_NOCTR(bytes);
    410410
     411#if defined(JAVASCRIPT)
     412#define CHECK_GC() 0
     413#else /* JAVASCRIPT */
    411414#define CHECK_GC()                                                      \
    412415  (bdescr_link(CurrentNursery) == NULL ||                               \
    413416   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))
     417#endif /* JAVASCRIPT */
    414418
    415419// allocate() allocates from the nursery, so we check to see
    416420// whether the nursery is nearly empty in any function that uses
     
    763767#define STM_AWOKEN                stg_STM_AWOKEN_closure
    764768#define END_INVARIANT_CHECK_QUEUE stg_END_INVARIANT_CHECK_QUEUE_closure
    765769
     770#if defined(JAVASCRIPT)
     771#define recordMutableCap(p, gen)
     772#else /* JAVASCRIPT */
    766773#define recordMutableCap(p, gen)                                        \
    767774  W_ __bd;                                                              \
    768775  W_ mut_list;                                                          \
     
    779786  free = bdescr_free(__bd);                                             \
    780787  W_[free] = p;                                                         \
    781788  bdescr_free(__bd) = free + WDS(1);
     789#endif /* JAVASCRIPT */
    782790
    783791#define recordMutable(p)                                        \
    784792      P_ __p;                                                   \