Add a --supported-languages flag

[ghc-hetmet.git] / compiler / nativeGen / AsmCodeGen.lhs

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index b3ca844..3036a7a 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -108,12 +108,12 @@ The machine-dependent bits break down as follows:
 
 -- NB. We *lazilly* compile each block of code for space reasons.
 
-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
 nativeCodeGen dflags cmms us
   = let (res, _) = initUs us $
           cgCmm (concat (map add_split cmms))
 
-       cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
+       cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
        cgCmm tops = 
           lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results -> 
           case unzip3 results of { (cmms,docs,imps) ->
@@ -196,17 +196,17 @@ nativeCodeGen dflags cmms us
 -- Complete native code generation phase for a single top-level chunk
 -- of Cmm.
 
-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
 cmmNativeGen dflags cmm
    = {-# SCC "fixAssigns"       #-} 
        fixAssignsTop cmm            `thenUs` \ fixed_cmm ->
      {-# SCC "genericOpt"       #-} 
-       cmmToCmm fixed_cmm           `bind`   \ (cmm, imports) ->
+       cmmToCmm dflags fixed_cmm           `bind`   \ (cmm, imports) ->
         (if dopt Opt_D_dump_opt_cmm dflags  -- space leak avoidance
           then cmm 
           else CmmData Text [])     `bind`   \ ppr_cmm ->
      {-# SCC "genMachCode"      #-}
-       genMachCode cmm              `thenUs` \ (pre_regalloc, lastMinuteImports) ->
+       genMachCode dflags cmm       `thenUs` \ (pre_regalloc, lastMinuteImports) ->
      {-# SCC "regAlloc"         #-}
        mapUs regAlloc pre_regalloc `thenUs`   \ with_regs ->
      {-# SCC "shortcutBranches"   #-}
@@ -390,13 +390,12 @@ apply_mapping ufm (CmmProc info lbl params blocks)
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
 
-genMachCode cmm_top
+genMachCode dflags cmm_top
   = do { initial_us <- getUs
-       ; let initial_st           = mkNatM_State initial_us 0
+       ; let initial_st           = mkNatM_State initial_us 0 dflags
              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
-             final_us             = natm_us final_st
              final_delta          = natm_delta final_st
              final_imports        = natm_imports final_st
        ; if   final_delta == 0
@@ -412,7 +411,7 @@ genMachCode cmm_top
 -- the generic optimiser below, to avoid having two separate passes
 -- over the Cmm.
 
-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 fixAssignsTop top@(CmmData _ _) = returnUs top
 fixAssignsTop (CmmProc info lbl params blocks) =
   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
@@ -429,9 +428,6 @@ fixAssigns stmts =
   returnUs (concat stmtss)
 
 fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal BaseReg) src)
-   = panic "cmmStmtConFold: assignment to BaseReg";
-
 fixAssign (CmmAssign (CmmGlobal reg) src)
   | Left  realreg <- reg_or_addr
   = returnUs [CmmAssign (CmmGlobal reg) src]
@@ -444,24 +440,6 @@ fixAssign (CmmAssign (CmmGlobal reg) src)
   where
        reg_or_addr = get_GlobalReg_reg_or_addr reg
 
-{-
-fixAssign (CmmCall target results args)
-  = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
-    returnUs (CmmCall target results' args :
-             concat stores)
-  where
-       fixResult g@(CmmGlobal reg,hint) = 
-         case get_GlobalReg_reg_or_addr reg of
-               Left realreg -> returnUs (g, [])
-               Right baseRegAddr ->
-                   getUniqueUs `thenUs` \ uq ->
-                   let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
-                   returnUs ((local,hint), 
-                             [CmmStore baseRegAddr (CmmReg local)])
-       fixResult other =
-         returnUs (other,[])
--}
-
 fixAssign other_stmt = returnUs [other_stmt]
 
 -- -----------------------------------------------------------------------------
@@ -490,28 +468,31 @@ Ideas for other things we could do (ToDo):
     temp assignments, and certain assigns to mem...)
 -}
 
-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
-cmmToCmm top@(CmmData _ _) = (top, [])
-cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
+cmmToCmm _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
   return $ CmmProc info lbl params blocks'
 
-newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 
 instance Monad CmmOptM where
-  return x = CmmOptM $ \imports -> (# x,imports #)
+  return x = CmmOptM $ \(imports, _) -> (# x,imports #)
   (CmmOptM f) >>= g =
-    CmmOptM $ \imports ->
-                case f imports of
+    CmmOptM $ \(imports, dflags) ->
+                case f (imports, dflags) of
                   (# x, imports' #) ->
                     case g x of
-                      CmmOptM g' -> g' imports'
+                      CmmOptM g' -> g' (imports', dflags)
 
 addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+
+getDynFlagsCmmOpt :: CmmOptM DynFlags
+getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
 
-runCmmOpt :: CmmOptM a -> (a, [CLabel])
-runCmmOpt (CmmOptM f) = case f [] of
+runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
                         (# result, imports #) -> (result, imports)
 
 cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
@@ -578,9 +559,13 @@ cmmExprConFold referenceKind expr
                  return $ cmmMachOpFold mop args'
 
         CmmLit (CmmLabel lbl)
-           -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+           -> do
+               dflags <- getDynFlagsCmmOpt
+               cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
         CmmLit (CmmLabelOff lbl off)
-           -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+           -> do
+                dflags <- getDynFlagsCmmOpt
+                dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                  return $ cmmMachOpFold (MO_Add wordRep) [
                      dynRef,
                      (CmmLit $ CmmInt (fromIntegral off) wordRep)