Ticket #7933: cmm_js.patch

File cmm_js.patch, 35.2 KB (added by bosu, 14 months 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;                                                   \