CoreRun.hs


-- UUAGC 0.9.52.1 (build/103/lib-ehc/UHC/Light/Compiler/CoreRun.ag)
module UHC.Light.Compiler.CoreRun(module UHC.Light.Compiler.CoreRun.Prim
, AGItf (..)
, Mod (..), SExp (..), Exp (..), MbExp, Alt (..), Pat (..)
, Meta (..), MetaL, DataCon (..), DataConL, Import (..), ImportL, Export (..), ExportL
, CRArray, CRMArray, emptyCRArray, crarrayToList, crarrayFromList, craLength, craAssocs, craAssocs', craReverseAssocs'
, Bind
, dbgs, dbg
, mbSExpr
, exp2sexp
, RRef (..), noRRef
, rrefResolve
, rrefToDif
, Ref2Nm
, Nm2RefMp, emptyNm2RefMp, nm2refUnion, nm2RefMpInverse, nm2refLookup
, ref2nmEmpty, ref2nmUnion, ref2nmLookup
, mkLocLevRef, mkLocDifRef, mkGlobRef, mkImpRef, mkExpRef, mkModRef, mkTagRef, mkFldRef
, mkExp, mkVar, mkVar', mkInt, mkInt', mkChar, mkChar', mkString, mkString'
, mkDbg, mkDbg'
, mkApp, mkApp', mkTup, mkTup', mkEval, mkTail, mkCase, mkLam, mkLam', mkLet, mkLet', mkFFI, mkFFI'
, mkImport
, mkMetaDataCon, mkMetaDataType
, mkMod, mkMod', mkModWithMetas, mkModWithImportsMetas, mkModWithImportsExportsMetas
, rrefToImp, rrefToExp, rrefResolveUnr
, mkInteger, mkInteger') where

import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.Target
import UHC.Util.Utils
import qualified UHC.Util.RelMap as Rel
import UHC.Light.Compiler.Ty
import qualified Data.Map as Map
import Data.Maybe
import Data.Char
import Data.List
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Control.Applicative
import UHC.Light.Compiler.CoreRun.Prim
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize
import UHC.Light.Compiler.Foreign































deriving instance Typeable Mod



-- | Fast access sequence
type CRArray  x =  V.Vector   x
type CRMArray x = MV.IOVector x

-- | Wrapper (rename) around vector<->list conversion
crarrayFromList :: [x] -> CRArray x
-- crarrayFromList = mkCRArrayLwb 0
crarrayFromList = V.fromList
{-# INLINE crarrayFromList #-}

-- | Wrapper (rename) around vector<->list conversion
crarrayToList :: CRArray x -> [x]
crarrayToList = V.toList
{-# INLINE crarrayToList #-}

emptyCRArray :: CRArray x
emptyCRArray = V.empty -- mkCRArray []
{-# INLINE emptyCRArray #-}

craLength :: CRArray x -> Int
craLength = V.length -- a = h + 1 - l
--  where (l,h) = bounds a
{-# INLINE craLength #-}

-- | Content of array as association list, starting index at 'lwb'
craAssocs' :: Int -> CRArray x -> [(Int,x)]
craAssocs' lwb = zip [lwb ..] . crarrayToList
{-# INLINE craAssocs' #-}

-- | Content of array as association list, starting index at 'lwb', but reversed
craReverseAssocs' :: Int -> CRArray x -> [(Int,x)]
craReverseAssocs' lwb v = zip [hi, hi-1  ..] $ V.toList v
  where hi = lwb + V.length v - 1
{-# INLINE craReverseAssocs' #-}

-- | Content of array as association list, starting index at 0
craAssocs :: CRArray x -> [(Int,x)]
craAssocs = craAssocs' 0
{-# INLINE craAssocs #-}



-- | Bind, just an Exp, addressing is left implicit
type Bind = Exp



-- | Equivalent of '()'
unit :: Exp
unit = Exp_Tup 0 emptyCRArray



-- | Debug info is embedded in SExp
dbgs = SExp_Dbg
dbg  = Exp_SExp . dbgs



-- | Is exp a SExp?
mbSExpr :: Exp -> Maybe SExp
mbSExpr (Exp_SExp s) = Just s
mbSExpr _            = Nothing



-- | Convert to SExp
exp2sexp :: Exp -> SExp
exp2sexp = maybe (dbgs "CoreRun.exp2sexp") id . mbSExpr



-- | Identifier references for use during running CoreRun
data RRef
  -- | global reference to module and its entry, will become obsolete, to be replaced by 'RRef_Mod', 'RRef_Exp', and RRef_Imp
  = RRef_Glb
      { rrefMod         :: !Int     -- ^ module
      , rrefEntry       :: !Int     -- ^ entry inside module
      }
  -- | entry of current module reference
  | RRef_Mod
      { rrefEntry       :: !Int     -- ^ entry inside module, in its frame
      }
  -- | Unresolved entry, to be resolved to a RRef_Imp (most likely)
  | RRef_Unr
      { rrefNm       	:: !HsName	-- ^ module name, to be looked up in a module specific import list for an index
      }
  -- | exported entry of module reference, only used internally to be later resolved to a 'RRef_Imp'
  | RRef_Exp
      { rrefModNm       :: !HsName	-- ^ module name, to be looked up in a module specific import list for an index
      , rrefEntry       :: !Int     -- ^ entry inside module, in its frame
      }
  -- | imported entry of module reference
  | RRef_Imp
      { rrefMod         :: !Int     -- ^ module (sequence) nr as it appears in the imported module list
      , rrefEntry       :: !Int     -- ^ entry inside module, in its frame
      }
  -- | local reference to on stack value, not interpreted during running, if used must be converted with 'rrefToDif' before running; may become obsolete.
  | RRef_Loc
      { rrefLev         :: !Int     -- ^ level when used statically
      , rrefEntry       :: !Int     -- ^ entry inside level
      }
  -- | local reference to on stack value, but measured relative to level of from where is referenced, used at runtime
  | RRef_LDf
      { rrefLevDiff		:: !Int     -- ^ offset/difference in levels when used at runtime
      , rrefEntry       :: !Int     -- ^ entry inside level
      }
  -- | tag of memory/constructor node referred to by other ref
  | RRef_Tag
      { rrefRef         :: !RRef    -- ^ of what this is the tag
      }
  -- | fld of memory/constructor node referred to by other ref
  | RRef_Fld
      { rrefRef         :: !RRef    -- ^ of what this is a field
      , rrefEntry       :: !Int     -- ^ entry inside node, zero base index
      }
  -- | debug variant, holding original name
  | RRef_Dbg
      { rrefNm          :: !HsName
      }
  deriving (Eq,Ord,Generic)

instance Show RRef where
  show _ = "RRef"

noRRef = RRef_Dbg hsnUnknown

-- | Map over the non-recursive parts of RRef
mapRRef :: (RRef -> RRef) -> RRef -> RRef
mapRRef f r@(RRef_Fld {rrefRef=r'}) = r {rrefRef = mapRRef f r'}
mapRRef f r@(RRef_Tag {rrefRef=r'}) = r {rrefRef = mapRRef f r'}
mapRRef f r                         = f r



-- | Resolve as far as possible
rrefResolve :: Maybe Int -> Maybe (HsName -> Maybe Int) -> Nm2RefMp -> HsName -> RRef
rrefResolve mbLev mbImpNmLkup nm2ref nm = maybe
  (RRef_Unr nm)
  ( maybe id rrefToDif mbLev
  . maybe id rrefToImp mbImpNmLkup
  )
  $ nm2refLookup nm nm2ref



-- | Convert to RRef_Exp to RRef_Imp, i.e. named module to indexed module ref
rrefToImp :: (HsName -> Maybe Int) -> RRef -> RRef
rrefToImp lkup = mapRRef f
  where f r@(RRef_Exp n o) = fromMaybe r $ {- hsnQualifier n >>= -} lkup n >>= (return . flip RRef_Imp o)
                             -- maybe r (flip RRef_Imp o) $ lkup $ panicJust "CoreRun.rrefToImp" $ hsnQualifier n
        f r                = r

-- | Convert to RRef_Mod to RRef_Exp, i.e. local module ref to exported
rrefToExp :: HsName -> RRef -> RRef
rrefToExp nm = mapRRef f
  where f r@(RRef_Mod o) = RRef_Exp nm o
        f r              = r

-- | Resolve RRef_Unr
rrefResolveUnr :: Maybe (HsName -> Maybe Int) -> Nm2RefMp -> RRef -> RRef
rrefResolveUnr mbImpNmLkup nm2ref = mapRRef f
  where f r@(RRef_Unr n) = rrefResolve Nothing mbImpNmLkup nm2ref n
        f r              = r



-- | Convert to RRef_Loc to RRef_LDf, i.e. absolute level to relative (to current) level
rrefToDif :: Int -> RRef -> RRef
rrefToDif curlev = mapRRef f
  where f r@(RRef_Loc l o) = RRef_LDf (curlev - l) o
        f r                = r
{-
rrefToDif curlev r@(RRef_Loc l o         ) = RRef_LDf (curlev - l) o
rrefToDif curlev r@(RRef_Fld {rrefRef=r'}) = r {rrefRef = rrefToDif curlev r'}
rrefToDif curlev r@(RRef_Tag {rrefRef=r'}) = r {rrefRef = rrefToDif curlev r'}
rrefToDif _      r                         = r
-}



-- | RRef to HsName mapping for use during running when a more informative name is required.
-- The representation is lazily via function
type Nm2RefRel = Rel.Rel HsName RRef -- RRef -> Maybe HsName



-- | RRef to HsName mapping for use during running when a more informative name is required.
-- The representation is lazily via function
type Ref2Nm = Nm2RefRel -- RRef -> Maybe HsName



-- | HsName to RRef mapping for resolving references during translation to CoreRun
type Nm2RefMp = Nm2RefRel -- Map.Map HsName RRef

emptyNm2RefMp :: Nm2RefMp
emptyNm2RefMp = Rel.empty -- Map.empty

nm2refUnion :: Nm2RefMp -> Nm2RefMp -> Nm2RefMp
nm2refUnion = Rel.union -- Map.union

nm2refLookup :: HsName -> Nm2RefMp -> Maybe RRef
nm2refLookup = Rel.lookup

-- | Inverse of a `Nm2RefMp`
nm2RefMpInverse :: Nm2RefMp -> Ref2Nm
nm2RefMpInverse m = m
{-
  | Map.null m = const Nothing
  | otherwise  = flip Map.lookup inv
  where inv = Map.fromList [ (r,n) | (n,r) <- Map.toList m ]
-}



-- | Empty Ref2Nm
ref2nmEmpty :: Ref2Nm
ref2nmEmpty = Rel.empty -- const Nothing

ref2nmLookup :: RRef -> Ref2Nm -> Maybe HsName
ref2nmLookup = Rel.lookupInverse

-- | Union, left-biased
ref2nmUnion :: Ref2Nm -> Ref2Nm -> Ref2Nm
ref2nmUnion = Rel.union -- m1 m2 = \r -> m1 r <|> m2 r



instance Serialize Mod where
  sput = sputPlain
  sget = sgetPlain

instance Binary RunPrim where
  put = putEnum
  get = getEnum

instance Binary a => Binary (CRArray a) where
  put = put . crarrayToList
  get = fmap crarrayFromList get



instance Binary Mod
instance Binary Meta
instance Binary Import
instance Binary Export
instance Binary DataCon
instance Binary Exp
instance Binary SExp
instance Binary Alt
instance Binary Pat
instance Binary RRef



-- **************************************
-- Construction: references
-- **************************************

-- | 'RRef' to local or outside scoped, using absolute level and offset (this is to be converted to a level difference + offset encoding for running, see 'mkLocDifRef')
mkLocLevRef :: Int -> Int -> RRef
mkLocLevRef = RRef_Loc

-- | 'RRef' to local or outside scoped, using level difference (to a current) and offset
mkLocDifRef :: Int -> Int -> RRef
mkLocDifRef = RRef_LDf

-- | 'RRef' to global from module, using module nr and offset (will become obsolete, replaced by either Imp or Mod Ref
mkGlobRef :: Int -> Int -> RRef
mkGlobRef = RRef_Glb

-- | 'RRef' to global from module, using module nr and offset
mkImpRef :: Int -> Int -> RRef
mkImpRef = RRef_Imp

-- | 'RRef' to global from module, using module name and offset
mkExpRef :: HsName -> Int -> RRef
mkExpRef = RRef_Exp

-- | 'RRef' to global from current module, using offset
mkModRef :: Int -> RRef
mkModRef = RRef_Mod

-- | 'RRef' to tag of node
mkTagRef :: RRef -> RRef
mkTagRef = RRef_Tag

-- | 'RRef' to field of node, using a zero based index
mkFldRef :: RRef -> Int -> RRef
mkFldRef = RRef_Fld



-- **************************************
-- Construction: constants as SExp or Exp
-- **************************************

-- | Lift 'SExp' into 'Exp'
mkExp :: SExp -> Exp
mkExp = Exp_SExp

-- | Var ref as 'SExp'
mkVar' :: RRef -> SExp
mkVar' = SExp_Var

-- | Var ref as 'Exp'
mkVar :: RRef -> Exp
mkVar = mkExp . mkVar'

-- | Int constant as 'SExp'
mkInt' :: Int -> SExp
mkInt' = SExp_Int

-- | Int constant as 'Exp'
mkInt :: Int -> Exp
mkInt = mkExp . mkInt'

-- | Char constant as 'SExp'
mkChar' :: Char -> SExp
mkChar' = SExp_Char

-- | Char constant as 'Exp'
mkChar :: Char -> Exp
mkChar = mkExp . mkChar'

-- | String constant as 'SExp'
mkString' :: String -> SExp
mkString' = SExp_String

-- | String constant as 'Exp'
mkString :: String -> Exp
mkString = mkExp . mkString'



-- | Debug info as 'SExp', will make an interpreter stop with displaying the message
mkDbg' :: String -> SExp
mkDbg' = dbgs

-- | Debug info as 'Exp'
mkDbg :: String -> Exp
mkDbg = dbg



-- | Integer constant as 'SExp'
mkInteger' :: Integer -> SExp
mkInteger' = SExp_Integer

-- | Integer constant as 'Exp'
mkInteger :: Integer -> Exp
mkInteger = mkExp . mkInteger'



-- **************************************
-- Construction: Exp
-- **************************************

-- | Application
mkApp' :: Exp -> CRArray SExp -> Exp
mkApp' = Exp_App

-- | Application
mkApp :: Exp -> [SExp] -> Exp
mkApp f as = mkApp' f (crarrayFromList as)

-- | Tuple, Node
mkTup' :: Int -> CRArray SExp -> Exp
mkTup' = Exp_Tup

-- | Tuple, Node
mkTup :: Int -> [SExp] -> Exp
mkTup t as = mkTup' t (crarrayFromList as)

-- | Force evaluation
mkEval :: Exp -> Exp
mkEval = Exp_Force

-- | Set tail call context
mkTail :: Exp -> Exp
mkTail = Exp_Tail

-- | Case
mkCase :: SExp -> [Exp] -> Exp
mkCase scrut alts = Exp_Case scrut $ crarrayFromList $ map (Alt_Alt ref2nmEmpty) alts

-- | Lambda
mkLam'
  :: Maybe HsName	-- ^ a name for this lambda, to be used for pretty printing
     -> Int			-- ^ nr of arguments, 0 encodes a thunk/CAF
     -> Int			-- ^ total stack size, including arguments, locals, expression calculation
     -> Exp 		-- ^ body
     -> Exp
mkLam' mbNm nrArgs stackDepth body = Exp_Lam mbNm nrArgs stackDepth ref2nmEmpty body

-- | Lambda
mkLam
  :: Int	-- ^ nr of arguments, 0 encodes a thunk/CAF
     -> Int	-- ^ total stack size, including arguments, locals, expression calculation
     -> Exp -- ^ body
     -> Exp
mkLam nrArgs stackDepth body = mkLam' Nothing nrArgs stackDepth body

-- | Let
mkLet'
  :: Int				-- ^ stackoffset to place bound value
     -> CRArray Exp		-- ^ bound terms
     -> Exp				-- ^ body
     -> Exp
mkLet' firstoff bs b = Exp_Let firstoff ref2nmEmpty bs b

-- | Let
mkLet
  :: Int				-- ^ stackoffset to place bound value
     -> [Exp]			-- ^ bound terms
     -> Exp				-- ^ body
     -> Exp
mkLet firstoff bs b = mkLet' firstoff (crarrayFromList bs) b

-- | FFI
mkFFI'
  :: String				-- ^ name of foreign entity, if unknown results in debug expr
     -> CRArray SExp	-- ^ args
     -> Exp
mkFFI' fe as = case Map.lookup fe allRunPrimMp of
  Just p -> Exp_FFI p as
  _      -> dbg $ "CoreRun.mkFFI: " ++ fe

-- | FFI
mkFFI
  :: String				-- ^ name of foreign entity, if unknown results in debug expr
     -> [SExp]			-- ^ args
     -> Exp
mkFFI fe as = mkFFI' fe (crarrayFromList as)



-- **************************************
-- Construction: Import
-- **************************************

-- | Meta: datatype constructor info
mkImport
  :: HsName		-- ^ name of imported module
     -> Import
mkImport = Import_Import



-- **************************************
-- Construction: Meta info
-- **************************************

-- | Meta: datatype constructor info
mkMetaDataCon
  :: HsName		-- ^ constructor name (without module qualifier, name must be globally unique)
     -> Int		-- ^ constructor tag
     -> DataCon
mkMetaDataCon = DataCon_Con

-- | Meta: datatype constructor info
mkMetaDataType
  :: HsName				-- ^ datatype name (fully qualified)
     -> [DataCon]		-- ^ constructor tag
     -> Meta
mkMetaDataType = Meta_Data




-- **************************************
-- Construction: Top level module
-- **************************************

-- | Module, with imports, with meta info
mkModWithImportsExportsMetas
  :: HsName				-- ^ module name
     -> Maybe Int		-- ^ module number, possibly (to become obsolete)
     -> Int				-- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation
     -> [Import]		-- ^ imports
     -> [Export]		-- ^ exports
     -> [Meta]			-- ^ meta info
     -> CRArray Bind	-- ^ bound expressions
     -> Maybe Exp		-- ^ body of main, absence of main indicated by Nothing
     -> Mod
mkModWithImportsExportsMetas modNm modNr stkDepth imports exports metas binds body = Mod_Mod ref2nmEmpty modNm modNr stkDepth imports exports metas binds body

-- | Module, with imports, with meta info
mkModWithImportsMetas
  :: HsName				-- ^ module name
     -> Maybe Int		-- ^ module number, possibly (to become obsolete)
     -> Int				-- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation
     -> [Import]		-- ^ imports
     -> [Meta]			-- ^ meta info
     -> CRArray Bind	-- ^ bound expressions
     -> Maybe Exp		-- ^ body of main, absence of main indicated by Nothing
     -> Mod
mkModWithImportsMetas modNm modNr stkDepth imports metas binds body = mkModWithImportsExportsMetas modNm modNr stkDepth imports [] metas binds body

-- | Module, with meta info
mkModWithMetas
  :: HsName				-- ^ module name
     -> Maybe Int		-- ^ module number, possibly (to become obsolete)
     -> Int				-- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation
     -> [Meta]			-- ^ meta info
     -> CRArray Bind	-- ^ bound expressions
     -> Exp				-- ^ body of main
     -> Mod
mkModWithMetas modNm modNr stkDepth metas binds body = mkModWithImportsMetas modNm modNr stkDepth [] metas binds (Just body)

-- | Module
mkMod'
  :: HsName				-- ^ module name
     -> Maybe Int		-- ^ module number, possibly (to become obsolete)
     -> Int				-- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation
     -> CRArray Bind	-- ^ bound expressions
     -> Exp				-- ^ body of main
     -> Mod
mkMod' modNm modNr stkDepth binds body = mkModWithMetas modNm modNr stkDepth [] binds body

-- | Module
mkMod
  :: HsName				-- ^ module name
     -> Maybe Int		-- ^ module number, possibly (to become obsolete)
     -> Int				-- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation
     -> [Bind]			-- ^ bound expressions
     -> Exp				-- ^ body of main
     -> Mod
mkMod modNm modNr stkDepth binds body = mkMod' modNm modNr stkDepth (crarrayFromList binds) body

-- AGItf -------------------------------------------------------
data AGItf = AGItf_AGItf {module_AGItf_AGItf :: !(Mod)}
           deriving ( Generic)
-- Alt ---------------------------------------------------------
data Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(Exp)}
         deriving ( Generic)
-- DataCon -----------------------------------------------------
data DataCon = DataCon_Con {conNm_DataCon_Con :: !(HsName),tagNr_DataCon_Con :: !(Int)}
             deriving ( Generic)
-- DataConL ----------------------------------------------------
type DataConL = [DataCon]
-- Exp ---------------------------------------------------------
data Exp = Exp_SExp {sexpr_Exp_SExp :: !(SExp)}
         | Exp_Tup {tag_Exp_Tup :: !(Int),args_Exp_Tup :: !((CRArray SExp))}
         | Exp_Let {firstOff_Exp_Let :: !(Int),ref2nm_Exp_Let :: !(Ref2Nm),binds_Exp_Let :: !((CRArray Bind)),body_Exp_Let :: !(Exp)}
         | Exp_App {func_Exp_App :: !(Exp),args_Exp_App :: !((CRArray SExp))}
         | Exp_Lam {mbNm_Exp_Lam :: !((Maybe HsName)),nrArgs_Exp_Lam :: !(Int),stkDepth_Exp_Lam :: !(Int),ref2nm_Exp_Lam :: !(Ref2Nm),body_Exp_Lam :: !(Exp)}
         | Exp_Force {expr_Exp_Force :: !(Exp)}
         | Exp_Tail {expr_Exp_Tail :: !(Exp)}
         | Exp_Case {expr_Exp_Case :: !(SExp),alts_Exp_Case :: !((CRArray Alt))}
         | Exp_FFI {prim_Exp_FFI :: !(RunPrim),args_Exp_FFI :: !((CRArray SExp))}
         deriving ( Generic)
-- Export ------------------------------------------------------
data Export = Export_Export {nm_Export_Export :: !(HsName),offset_Export_Export :: !(Int)}
            deriving ( Generic)
-- ExportL -----------------------------------------------------
type ExportL = [Export]
-- Import ------------------------------------------------------
data Import = Import_Import {nm_Import_Import :: !(HsName)}
            deriving ( Generic)
-- ImportL -----------------------------------------------------
type ImportL = [Import]
-- MbExp -------------------------------------------------------
type MbExp = Maybe (Exp)
-- Meta --------------------------------------------------------
data Meta = Meta_Data {tyNm_Meta_Data :: !(HsName),dataCons_Meta_Data :: !(DataConL)}
          deriving ( Generic)
-- MetaL -------------------------------------------------------
type MetaL = [Meta]
-- Mod ---------------------------------------------------------
data Mod = Mod_Mod {ref2nm_Mod_Mod :: !(Ref2Nm),moduleNm_Mod_Mod :: !(HsName),moduleNr_Mod_Mod :: !((Maybe Int)),stkDepth_Mod_Mod :: !(Int),imports_Mod_Mod :: !(ImportL),exports_Mod_Mod :: !(ExportL),metas_Mod_Mod :: !(MetaL),binds_Mod_Mod :: !((CRArray Bind)),mbbody_Mod_Mod :: !(MbExp)}
         deriving ( Generic)
-- Pat ---------------------------------------------------------
data Pat = Pat_Con {tag_Pat_Con :: !(Int)}
         deriving ( Generic)
-- SExp --------------------------------------------------------
data SExp = SExp_Var {ref_SExp_Var :: !(RRef)}
          | SExp_Int {int_SExp_Int :: !(Int)}
          | SExp_Char {char_SExp_Char :: !(Char)}
          | SExp_String {str_SExp_String :: !(String)}
          | SExp_Integer {integer_SExp_Integer :: !(Integer)}
          | SExp_Dbg {msg_SExp_Dbg :: !(String)}
          deriving ( Generic)