work on cmm (ident adm cleanup), refactor of transformation monad (ge…

…tting rid of old copy/paste)

EHC/src/ehc/Base/Common.chs

@@ -405,6 +405,9 @@ data TagDataInfo = TagDataInfo
 
 instance Eq TagDataInfo where
   i1 == i2 = tagDataInfoConstrNm i1 == tagDataInfoConstrNm i2
+
+instance Ord TagDataInfo where
+  i1 `compare` i2 = tagDataInfoConstrNm i1 `compare` tagDataInfoConstrNm i2
 %%]
 
 %%[8 hs export(mkTyIsConTagInfo, mkConTagInfo, emptyTagDataInfo)

EHC/src/ehc/Base/HsName.chs

@@ -284,6 +284,15 @@ data HsName
   deriving (Eq,Ord)
 %%]
 
+%%[1111 export(hsnIsEmpty)
+hsnIsEmpty (HsName_Base s) = null s
+%%[[7
+hsnIsEmpty (HsName_Modf {hsnBase=b})
+                           = hsnIsEmpty b
+%%]]
+hsnIsEmpty _               = False
+%%]
+
 %%[1
 -- | Smart constructor for HsName_Modf
 hsnMkModf :: [String] -> HsName -> HsNameUniqifierMp -> HsName

EHC/src/ehc/Base/UID.chs

@@ -33,13 +33,14 @@
 %%% Monadic interface to Unique id
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-%%[1 export(FreshUidT, FreshUid, freshUID, runFreshUidT, runFreshUid, evalFreshUid)
+%%[1 export(FreshUidT, FreshUid, runFreshUidT, runFreshUid, evalFreshUid)
 type FreshUidT m   = StateT UID m
 type FreshUid      = FreshUidT Identity
 
+{-
 freshUID :: MonadState UID m => m UID
 freshUID = state $ \x -> (x, uidNext x)
-{-# INLINE freshUID #-}
+-}
 
 runFreshUidT :: Monad m => FreshUidT m a -> UID -> m (a,UID)
 runFreshUidT f u = runStateT f u
@@ -54,6 +55,26 @@ evalFreshUid f u = fst $ runIdentity $ runFreshUidT f u
 {-# INLINE evalFreshUid #-}
 %%]
 
+%%[1 export(MonadFreshUID(..))
+class Monad m => MonadFreshUID m where
+  -- | Fresh single UID
+  freshUID :: m UID
+  freshUID = freshInfUID
+
+  -- | Fresh infinite range of UID 
+  freshInfUID :: m UID
+  freshInfUID = freshUID
+
+-- TBD: flip results of mkNewLevUID (etc) to be in agreement with behavior of state
+instance Monad m => MonadFreshUID (FreshUidT m) where
+  freshUID = state $ \x -> (x, uidNext x)
+  {-# INLINE freshUID #-}
+
+  freshInfUID = state $ \x -> (uidChild x, uidNext x)
+  {-# INLINE freshInfUID #-}
+%%]
+
+
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %%% Unique id's
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

EHC/src/ehc/Cmm.cag

@@ -72,6 +72,11 @@ DERIVING *
   : Eq, Ord
 %%]
 
+%%[(8 codegen cmm) ag
+DERIVING AllTy Tag
+  : Eq, Ord
+%%]
+
 -- debug only
 %%[(8888 codegen cmm) hs import({%{EH}Base.Debug},UHC.Util.Pretty)
 %%]
@@ -149,10 +154,16 @@ instance TagLike Tag where
 %%% Constructing: module, toplevel
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-%%[(8 codegen cmm) hs export(imp)
+%%[(8 codegen cmm) hs export(imp,impcvars)
 -- | Import
-imp :: NmL -> Decl
-imp ns = Decl_Import (map (Import_Imp Nothing) ns)
+imp :: Maybe Nm -> AssocL Nm Ty -> Decl
+imp mod ns = Decl_Import mod [ Import_Imp (Just t) Nothing n | (n,t) <- ns ]
+
+-- | Import external CVar_GlobalExtern, rest is ignored
+impcvars :: [CVarInfo] -> TopLevelL
+impcvars ns
+  = [ TopLevel_Decl $ imp (Just mod) [(cvarFldNm i, cvarType i) | i <- is] | (is@(CVar_GlobalExtern {cvarModNm=mod} :_)) <- exts ]
+  where exts = groupOn cvarModNm $ filter cvarIsGlobExt ns
 %%]
 
 %%[(8 codegen cmm) hs export(arr)

EHC/src/ehc/Cmm/AbsSyn.cag

@@ -45,7 +45,8 @@ TYPE SectionL		= [Section]
 
 %%[(8 cmm)
 DATA Decl
-  | Import			imports			: ImportL
+  | Import			mbFromNm		: {Maybe Nm}
+  					imports			: ImportL
   | Export			exports			: ExportL
   | Const			ckind			: ConstKind
   					mbTy			: MbTy
@@ -76,15 +77,16 @@ DATA Target
 TYPE TargetL		= [Target]
 
 DATA Import
-  | Imp 			mbOrigNm		: {Maybe String}
+  | Imp 			mbTy			: MbTy
+  					mbOrigNm		: {Maybe String}
   					nm				: Nm
 
 TYPE ImportL		= [Import]
 
 DATA Export
-  | Exp				nm				: Nm
+  | Exp				cvar			: CVarInfo
   					ty				: Ty
-  | ExpAs			nm				: Nm
+  | ExpAs			cvar			: CVarInfo
   					ty				: Ty
   					snmAs			: String
 
@@ -183,7 +185,7 @@ DATA Formal
   | Formal			mbKind			: {Maybe String}
   					isInvariant		: Bool
   					ty				: Ty
-  					nm				: Nm
+  					cvar			: CVarInfo
 
 TYPE FormalL		= [Formal]
 

EHC/src/ehc/Cmm/Pretty.cag

@@ -69,11 +69,16 @@ SEM Section
 
 %%[(8 cmm)
 SEM Decl
-  | Import		lhs		.	pp		=	semic $ "import" >#< ppCommas' @imports.ppL
-  | Export		lhs		.	pp		=	semic $ "export" >#< ppCommas' @exports.ppL
-  | Const		lhs		.	pp		=	semic $ show @ckind >#< @mbTy.pp >#< cvar @cvar >#< "=" >#< @expr.pp
-  | ConstArray	lhs		.	pp		=	semic $ "const" >#< @mbTy.pp >#< @nm >|< "[]" >#< "=" >#< ppCurlysCommasBlock @exprs.ppL
-  | Typedef		lhs		.	pp		=	semic $ "typedef" >#< @ty.pp >#< ppCommas' @nms
+  | Import      lhs     .   pp      =   semic $ "import" >#< 
+                                            (let ns = ppCommas' @imports.ppL
+                                             in  case @mbFromNm of
+                                                    Nothing -> ns
+                                                    Just fr -> "module" >#< fr >|< ppParens ns
+                                            )
+  | Export      lhs     .   pp      =   semic $ "export" >#< ppCommas' @exports.ppL
+  | Const       lhs     .   pp      =   semic $ show @ckind >#< @mbTy.pp >#< cvar @cvar >#< "=" >#< @expr.pp
+  | ConstArray  lhs     .   pp      =   semic $ "const" >#< @mbTy.pp >#< @nm >|< "[]" >#< "=" >#< ppCurlysCommasBlock @exprs.ppL
+  | Typedef     lhs		.	pp		=	semic $ "typedef" >#< @ty.pp >#< ppCommas' @nms
   | Regs		lhs		.	pp		=	semic $ (if @isInvariant then "invariant " else "")	>|< @regs.pp
   -- | Pragma			nm				: Nm
   -- 					pragma			: PragmaL
@@ -91,7 +96,7 @@ SEM Target
 
 %%[(8 cmm)
 SEM Import
-  | Imp			lhs		.	pp		=	ppMbPre (\s -> show s >#< "as") @mbOrigNm @nm
+  | Imp			lhs		.	pp		=	ppMbPre id @mbTy.ppMb $ ppMbPre (\s -> s >#< "as") @mbOrigNm @nm
 %%]
 
 Export
@@ -147,7 +152,7 @@ SEM Conv
 
 %%[(8 cmm)
 SEM Formal
-  | Formal		lhs		.	pp		=	ppMbPre show @mbKind $ (if @isInvariant then "invariant " else "") >|< @ty.pp >#< @nm
+  | Formal		lhs		.	pp		=	ppMbPre show @mbKind $ (if @isInvariant then "invariant " else "") >|< @ty.pp >#< cvar @cvar
 %%]
 
 %%[(8 cmm)

EHC/src/ehc/Cmm/ToC.cag

@@ -79,13 +79,13 @@ SEM Body
   | Body				lhs			.	c		=	ppCurlysBlock @decls.lc
 
 SEM Formal
-  | Formal				lhs			.	c		=	gencFunDefArg @ty.c @nm
+  -- | Formal				lhs			.	c		=	gencFunDefArg @ty.c @nm			-- TBD: cvar sort out
 
 SEM Import
-  | Imp					lhs			.	c		=	gencInclude' "h" @nm
+  -- | Imp					lhs			.	c		=	gencInclude' "h" @nm			-- TBD: cvar sort out
 
 SEM Export
-  | Exp	ExpAs			lhs			.	c		=	gencEndsemic $ gencExtern $ @ty.c >#< @nm
+  -- | Exp	ExpAs			lhs			.	c		=	gencEndsemic $ gencExtern $ @ty.c >#< @nm			-- TBD: cvar sort out
 %%]
 
 Top level global data

EHC/src/ehc/Cmm/ToJavaScript.cag

@@ -114,9 +114,10 @@ jdefNm :: CVarNmModuleCfg -> {- CVarMp -> -} CVarInfo -> HsName
       -> cvarToRef
           ( \n       -> JS.var $ mkErrNm n
           , \_       -> JS.Expr_This
-          , \_ o     -> JS.var $ fldNm o
-          , \_ _ f   -> JS.var f
-          , \_ _ f   -> JS.var f
+          , mkLoc
+          , mkLoc
+          , mkGlEx
+          , mkGlIn
           , \_ e _ f -> JS.Expr_ObjFld e f -- (fldNm f)
           , \_ e     -> JS.Expr_ObjFld e JS.nmTag
           , \  e o   -> JS.Expr_ArrInx e o
@@ -128,7 +129,7 @@ jdefNm :: CVarNmModuleCfg -> {- CVarMp -> -} CVarInfo -> HsName
     , \cfg cvi
       -> cvarToDefHsName
           ( mkErrNm . mkHNm
-          , mkHNm
+          , unq . mkHNm
           , mkHNm
           , mkHNm
           , mkTag
@@ -138,6 +139,11 @@ jdefNm :: CVarNmModuleCfg -> {- CVarMp -> -} CVarInfo -> HsName
     )
   where mkErrNm = hsnPrefix "#ERRREF#"
         mkTag   = \_ _ -> panic "JavaScript.cvarToXXX.mkTag should not be used"
+        mkLoc   = \_ o -> JS.var $ unq $ fldNm o
+        mkGlEx	= \_ m f -> JS.var $ q m f
+        mkGlIn	= \_ m f -> JS.var $ maybe f (flip q f) m
+        unq = hsnQualified
+        q   = hsnSetQual
 %%]
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -190,7 +196,7 @@ SEM RegNmInit
   | NmInit	        	loc         .   jsnm	=   jdefNm @lhs.cvarNmModCfg @cvar -- JS.hsnJavaScriptVar @lhs.cvarNmModCfg False @nm
 
 SEM Formal
-  | Formal        		loc         .   jsnm	=   JS.hsnJavaScriptVar @lhs.cvarNmModCfg False @nm
+  | Formal        		loc         .   jsnm	=   jdefNm @lhs.cvarNmModCfg @cvar -- JS.hsnJavaScriptVar @lhs.cvarNmModCfg False @nm
 
 SEM KindName
   | KindName        	loc         .   jsnm	=   JS.hsnJavaScriptVar @lhs.cvarNmModCfg False @nm
@@ -224,7 +230,7 @@ SEM Module
                                                                 mkd n e | isJust q  = JS.assign n e
                                                                         | otherwise = JS.vardecl n (Just e)
                                                                   where q = hsnQualifier n
-                                                            in  L.map (\n -> mkd n $ mk n) $ concat $ reverse $ takeWhile (not . L.null) $ iterate prefixes $ Set.toList $ iumHIUsedModules @lhs.importUsedModules
+                                                            in  L.map (\n -> mkd n $ mk n) $ concat $ reverse $ takeWhile (not . L.null) $ iterate prefixes $ Set.toList $ iumIntrodModules @lhs.importUsedModules
 %%]]
 %%[[8
                         loc         .   jsModTraceStats =   if ehcOptGenTrace @lhs.opts then [JS.assign (mkHNm "traceOn") JS.Expr_True] else []