CoreRun.hs


-- UUAGC 0.9.50.2 (build/103/lib-ehc/UHC/Light/Compiler/CoreRun.ag)
module UHC.Light.Compiler.CoreRun(module UHC.Light.Compiler.CoreRun.Prim
, Mod (..), SExp (..), Exp (..), Alt (..), Pat (..)
, CRArray, CRMArray, emptyCRArray, crarrayToList, crarrayFromList, craLength, craAssocs, craAssocs', craReverseAssocs'
, Bind
, dbgs, dbg
, mbSExpr
, exp2sexp
, RRef (..), noRRef
, rrefToDif
, Ref2Nm
, Nm2RefMp, nm2RefMpInverse, ref2nmEmpty, ref2nmUnion
, mkLocLevRef, mkLocDifRef, mkGlobRef
, mkExp, mkVar, mkVar', mkInt, mkInt', mkChar, mkChar', mkString, mkString'
, mkDbg, mkDbg'
, mkApp, mkApp', mkTup, mkTup', mkEval, mkTail, mkCase, mkLam, mkLam', mkLet, mkLet', mkFFI, mkFFI'
, mkMod, mkMod'
, mkInteger, mkInteger') where

import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.Target
import UHC.Util.Utils
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 UHC.Light.Compiler.Foreign























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

{-
-- | Make array with lowerbound
mkCRArrayLwb :: Int -> [x] -> CRArray x
mkCRArrayLwb lwb xs = listArray (lwb,lwb+l-1) xs
  where l = length xs
-}

-- | 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
  = RRef_Glb
      { rrefMod         :: !Int     -- ^ module
      , rrefEntry       :: !Int     -- ^ entry inside module
      }
  -- | local reference to on stack value, not interpreted during running
  | 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 (not yet used)
  | 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 level
      }
  -- | debug variant, holding original name
  | RRef_Dbg
      { rrefNm          :: !HsName
      }
  deriving (Eq,Ord)

instance Show RRef where
  show _ = "RRef"

noRRef = RRef_Dbg hsnUnknown



-- | Convert to RRef_Loc to RRef_LDf, i.e. absolute level to relative (to current) level
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 Ref2Nm = RRef -> Maybe HsName



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

-- | Inverse of a `Nm2RefMp`
nm2RefMpInverse :: Nm2RefMp -> Ref2Nm
nm2RefMpInverse 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 = const Nothing

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



-- **************************************
-- 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
mkGlobRef :: Int -> Int -> RRef
mkGlobRef = RRef_Glb



-- **************************************
-- 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: Top level module
-- **************************************

-- | Module
mkMod'
  :: HsName				-- ^ module name
     -> Int				-- ^ module number
     -> 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 = Mod_Mod ref2nmEmpty modNm modNr stkDepth binds body

-- | Module
mkMod
  :: HsName				-- ^ module name
     -> Int				-- ^ module number
     -> 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

-- Alt ---------------------------------------------------------
data Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(Exp)}
-- 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))}
-- Mod ---------------------------------------------------------
data Mod = Mod_Mod {ref2nm_Mod_Mod :: !(Ref2Nm),moduleNm_Mod_Mod :: !(HsName),moduleNr_Mod_Mod :: !(Int),stkDepth_Mod_Mod :: !(Int),binds_Mod_Mod :: !((CRArray Bind)),body_Mod_Mod :: !(Exp)}
-- Pat ---------------------------------------------------------
data Pat = Pat_Con {tag_Pat_Con :: !(Int)}
         | Pat_BoolExpr {expr_Pat_BoolExpr :: !(Exp)}
-- 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)}