Plan 9 from Bell Labs’s /usr/web/sources/contrib/fernan/nhc98/src/compiler98/GcodeFix.hs

Copyright © 2021 Plan 9 Foundation.
Distributed under the MIT License.
Download the Plan 9 distribution.


module GcodeFix(gcodeFixInit,gcodeFix,gcodeFixFinish) where

import Gcode
import IntState(uniqueIS,lookupIS,globalIS,arityIS,miIS)
import Memo
import AssocTree
import TokenId (TokenId(..))
import State
import Info hiding (TokenId)
import Util.Extra
import GcodeLow(cap0,caf,fun,string,profstatic,profproducer,profconstructor,profmodule,tprofmodule,tprofmodulesub,consttable,lowInteger,extra,wsize,align)
import GcodeSpec(fixProfstatic,compilerProfstatic)
import Flags
import Maybe

data Down = Down 

data Thread = Thread 
       IntState  -- state  
       Bool -- prof 
       (AssocTree (Int,Int) Int) -- profstatics
       ((AssocTree String Int),[(Int,Gcode)]) -- strings, extralabels
       Bool  -- live
       (Memo Int)  -- used labels
       Int [Gcode] -- before 
       Int [Gcode] -- after

type FixState = (AssocTree (Int,Int) Int, (AssocTree String Int, [(Int,Gcode)]))

gcodeFixInit :: IntState -> Flags -> (IntState,(AssocTree a b,(AssocTree [Char] Int,[(Int,Gcode)])))

gcodeFixInit state flags =
  case uniqueIS state of
    (mlabel,state) ->
      let fn = fromEnum (miIS state)
          name = (show . profI . fromJust . lookupIS state . toEnum) fn
      in if sProfile flags || sFunNames flags || sTprof flags then
           if sPart flags then
             (state,(initAT,(initAT,[(fromEnum mlabel,GLOBAL profmodule fn)])))
	   else 
	     (state,(initAT,(addAT initAT sndOf name (fromEnum mlabel),[(fromEnum mlabel,GLOBAL profmodule fn)])))
         else
	   (state,(initAT,(initAT,[])))



gcodeFix flags state (profstate,stringstate) gcode =
  let prof  = sProfile flags
      tprof = sTprof flags
      funnames = prof || tprof || sFunNames flags
      thread = (tprof,funnames,prof,state,profstate,stringstate)
  in case {- mapS -} fixOne gcode () thread of
       (gcode,(prof,state,profstate,stringstate)) ->
   	 (state,(profstate,stringstate),gcode)

gcodeFixFinish state (profstate,(strings,elabels)) =
   [concatMap (fixProfstatic state) (listAT profstate)] ++ [concatMap (fixString elabels) (listAT strings)]


{---------------- DAVID ------------------- -}
escNul [] = []
escNul ('\\':xs) = '\\':'\\': escNul xs
escNul ('\0':xs) = '\\':'\0': escNul xs
escNul (x:xs) = x : escNul xs
{---------------- DAVID ------------------- -}

fixString elabels (s,i) = (map snd . filter ((i==).fst)) elabels ++ [LOCAL string i, DATA_S s]

fixOne [] _ (tprof,funnames,prof,state,profstatics,strings) =
    ([],(prof,state,profstatics,strings))
fixOne (g@(STARTFUN pos fn):gs) _ (tprof,funnames,prof,state,profstatics,strings) =
  let a = arityIS state (toEnum fn)
      thread = Thread state prof profstatics strings True initM 
                      (if funnames then -2 else 0) []   -- if funnames | profile then Position at -2 and Name at -1
                      (2+if prof then extra else 0) []  --  size/arity at 0, link at 1, CAF/CAP0 at 2
      label = if globalIS state (toEnum fn) then GLOBAL else LOCAL

      info = (fromJust . lookupIS state . toEnum) fn
      name = show (profI info)
  in                                          -- Maybe use some other producer 
    case (unitS triple =>>> (if prof then addStatic fn fn else unitS 0)
		       =>>> (if funnames then 
		                addString name  (if prof then [label profproducer fn,label profconstructor fn] else [])
                             else
                                unitS undefined)
		       =>>> mapS gFix gs) (Down ) thread of
      ((plabel,slabel,gs),Thread state _ profstatics strings _ _ nbs bs nas as) ->
          case uniqueIS state of
            (clabel,state) ->
              (capTable a ++
	       DATA_GLB consttable (fromEnum clabel) :
	       label fun fn :
               (if tprof then tpgcode info state else []) ++
               g:concat gs  ++
	       ALIGN_CONST:
	       (case align 8 (-nbs * wsize) of
                    0 -> []
                    f -> take (f `div` wsize) (repeat (DATA_W 0))
               ) ++
	       bs ++
	       (if funnames then [DATA_W pos,DATA_GLB string slabel] else []) ++
	       LOCAL consttable (fromEnum clabel) :
	       DATA_CONSTHEADER (length as) a:		-- number of pointers and arity
	       DATA_W  0:			-- link for gc
	       (if a == 0 then [label caf fn, DATA_VAP fn] else [label cap0 fn, DATA_CAP fn a]) ++
	       compilerProfstatic prof state plabel ++
	       reverse as
	      ,(prof,state,profstatics,strings))

--PHtprof
tpgcode :: Info -> IntState -> [Gcode]
tpgcode info state = let mod = fromEnum (miIS state)
                         sub = case info of
                               (InfoName _ _ _ _ True) -> tprofmodulesub
                               otherwise               -> tprofmodule
                     in [DATA_GLB sub mod]

capTable a = 
  let fill = align wsize (2 * a + 2) `div` 2
		-- one extra table item compared to arity
  in take fill (repeat (DATA_CAPITEM 0 0)) ++ cT a a
 where
  cT a n =
    if n>=0 then
      DATA_CAPITEM (a-n) n : cT a (n-1)
    else
      []


gUnique down thread@(Thread state prof profstatics strings live
                            labels nbs bs nas as) =
  case uniqueIS state of
    (u,state) -> (u,Thread state prof profstatics strings live
                           labels nbs bs nas as)

gState down thread@(Thread state prof profstatics strings live
                           labels nbs bs nas as) =
  (state,thread)

gInfo i down thread@(Thread state prof profstatics strings live
                            labels nbs bs nas as) =
  (lookupIS state i,thread)

useLabel i down thread@(Thread state prof profstatics strings live
                               labels nbs bs nas as) = 
  Thread state prof profstatics strings live (addM labels i) nbs bs nas as

ifLive f down thread@(Thread state prof profstatics strings live
                             labels nbs bs nas as) = 
  if live then
    f down thread
  else 
    ([],thread)

emits g down thread@(Thread state prof profstatics strings live
                            labels nbs bs nas as) =
  (g, thread)

emit g = emits [g]

conInfo i down thread@(Thread state prof profstatics strings live
                              labels nbs bs nas as) = 
  case lookupIS state i of
    Just (InfoName u (TupleId a) t _ _) -> ((a,0),thread)
	-- !!! NR the only constructors that can use InfoName is tuples !!!
	--PHtprof
    Just cinfo@(InfoConstr _ _ _ _ _ _ idata) ->
      case lookupIS state idata of
	Just info  ->
	    ((arityI cinfo,nthcon 0 i (constrsI info)),thread)
 where
  nthcon n con (c:cs) = if con == c then n else nthcon (n+1) con cs
  nthcon n con [] =
      error ("GcodeFix.nthcon: (n=="++show n++") (con=="++show con++") []\n")



addString str els down thread@(Thread state prof profstatics (strings,elabels) live labels nbs bs nas as) = 
  case lookupAT strings str of
    Just l -> if null els then (l,thread)
	      else (l,Thread state prof profstatics (strings,map (pair l) els ++ elabels) live labels nbs bs nas as)
    Nothing ->
      case uniqueIS state of
        (l,state) -> (fromEnum l,Thread state prof profstatics (addAT strings sndOf str (fromEnum l),map (pair (fromEnum l)) els ++ elabels) live labels nbs bs nas as)

addStatic p c down thread@(Thread state prof profstatics strings live labels nbs bs nas as) = 
  case lookupAT profstatics (p,c) of
    Just l -> (l,thread)
    Nothing ->
      case uniqueIS state of
        (l,state) -> (fromEnum l,Thread state prof (addAT profstatics sndOf (p,c) (fromEnum l)) strings live labels nbs bs nas as)

addDouble gs down thread = addBefore' True gs down thread

addBefore gs down thread = addBefore' False gs down thread

addBefore' align8 gs' down thread@(Thread state prof profstatics strings live labels nbs bs nas as) = 
  case search gs nbs bs of
    Just nbs' -> (nbs',thread)
    Nothing ->
      let (nbs',bs') = if align8 then 
                         let fill = align 8 (wsize * (-nbs)) `div` wsize
			 in (nbs-fill,take fill (repeat (DATA_W 0))++bs)
		       else
			 (nbs,bs)
          nbs'' = nbs' - length gs
      in (nbs'',Thread state prof profstatics strings live labels nbs'' (gs++bs') nas as)
 where
        -- We need module, producer (compiler?), and constructor !!!
  gs = if prof then head gs' : DATA_W 0 :  DATA_CREATE : DATA_W 0 : DATA_W 0 : tail gs' else gs'

  eqInit [] _ = True 
  eqInit (a:as) (b:bs) = a == b && eqInit as bs

  search gs nbs [] = Nothing
  search gs nbs bbs@(b:bs) =
	if eqInit gs bbs then Just nbs
	else let nbs1 = nbs+1
             in seq nbs1 (search gs nbs1 bs)


addAfter g down thread@(Thread state prof profstatics strings live labels nbs bs nas as) = 
  case search g nas as of
    Just nas' -> (nas',thread)
    Nothing ->
      let nas' = nas + 1
      in (nas',Thread state prof profstatics strings live labels nbs bs nas' (g:as))
 where
  search g nas [] = Nothing
  search g nas (a:as) =
	if g == a then Just nas
	else let nas1 = nas-1
             in seq nas1 (search g nas1 as)


gFix g@(NEEDHEAP i) = ifLive (emit g)
gFix g@(NEEDSTACK i) = ifLive (emit g)
gFix g@(LABEL i) = ifLive (emit g)
gFix g@(JUMP  i) = ifLive (useLabel i >>> emit g)
gFix g@(JUMPFALSE i) = ifLive (useLabel i >>> emit g)	-- DAVID

-- If this case isn't full, then defpop must be Just (def,pop) or we have an internal error
gFix g@(CASE alts defpop) = ifLive $
  mapS0 (useLabel.snd) alts >>>
  gUnique >>>= \ poplabel ->
  case alts of
    ((GALT_CON c,_):_) ->
      gInfo (toEnum c) >>>= \ coninfo ->
      gInfo ((belongstoI . fromJust) coninfo) >>>= \ typeinfo ->
      let constrs = (constrsI . fromJust)  typeinfo
          matched = map dropGALT alts
	  usedef = length constrs /= length matched 
          (def,pop) = fromJust defpop
          ls      = map (fromEnum . reorder poplabel matched . fromEnum)
                        constrs -- DAVID
      in
      (if usedef then useLabel def else unitS0) >>>	-- DAVID
            emits (TABLESWITCH (length ls) 0 ls :	-- DAVID
             (if usedef then				-- DAVID
                  [LABEL (fromEnum poplabel), POP pop, JUMP def]	-- DAVID
             else					-- DAVID
                  [])					-- DAVID
            )						-- DAVID
{-------------------- DAVID ---------------
      (if usedef then useLabel def else	unitS0) >>>
      emits (MATCHCON : JUMPS_T :  (map (JUMPTABLE . reorder poplabel matched) constrs) ++
	     (if usedef then
	      [LABEL poplabel, POP pop, JUMP def]
	     else
	      []
             )
	    )
 ----------- DAVID -------------------------- -}

    ((GALT_INT _,_):_) ->
      let (def,pop) = fromJust defpop -- Never all contructors when matching ints
          tls       = map dropGALT alts in
        emits (LOOKUPSWITCH (length tls) 0 tls (fromEnum poplabel) :

{------------ DAVID -------------------------
      emits (MATCHINT : JUMPS_L : JUMPLENGTH (length alts) poplabel : map ( \ (GALT_INT i,l) -> JUMPLIST i l) alts ++
 ------------- DAVID -------------------- --}
	     [LABEL (fromEnum poplabel), POP pop, JUMP def]
	    )
 where

  dropGALT (GALT_CON c,l) = (c, toEnum l)
  dropGALT (GALT_INT i,l) = (i, toEnum l)

  reorder d ms c =
    case lookup c ms of
      Nothing -> d
      Just l -> l

gFix g@(PRIMITIVE) = ifLive (emit g)
gFix g@(DATA_CREATE) = ifLive (emit g)
gFix g@(DATA_GLB string label) = ifLive (emit g)
gFix g@(DATA_CLABEL label) = ifLive (emit g)
gFix g@(DATA_FLABEL label) = ifLive (emit g)
gFix g@(MKIORETURN) = ifLive (emit g)

gFix g@(PRIM prim) = ifLive (emit g)

-- Stack
gFix g@(PUSH_INT  i) =  ifLive $ 
  if i >= -10 && i < 256 then
    emit g
  else
    addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_CHAR  i) =  ifLive $ 
  if i >= -10 && i < 256 then
    emit g
  else
    addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_INTEGER  i) = ifLive $
    addBefore (lowInteger i) >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_FLOAT f) = ifLive $
    addBefore [DATA_CONW 1 0,DATA_F f] >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_DOUBLE d) = ifLive $
    addDouble [DATA_CONW 2 0,DATA_D d,DATA_NOP] >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_STRING  s) = ifLive $
    addString (escNul s) [] >>>= \ label ->
    addBefore [DATA_CONW 1 0,DATA_GLB string label] >>>= \ i ->
    emits [PUSH_CADR i, EVALUATED]
gFix g@(PUSH_ARG  i) = ifLive (emit g)
gFix g@(PUSH_ZAP_ARG  i) = ifLive (emit g)
gFix g@(PUSH      i) = ifLive (emit g)
gFix g@(PUSH_HEAP  ) = ifLive (emit g)
gFix g@(PUSH_GLB s i) = ifLive $
    addAfter (DATA_GLB s i) >>>= \ i ->
    emit (PUSH_CVAL i)

gFix g@(POP       i) = ifLive (emit g)
gFix g@(SLIDE     i) = ifLive (emit g)
gFix g@(UNPACK    i) = ifLive (emit g)

-- selector
gFix g@(SELECTOR_EVAL) = ifLive (emit g)
gFix g@(SELECT   i) = ifLive (emit g)

-- evaluation
gFix g@(APPLY   i) = ifLive (emit g)
gFix g@(EVAL) = ifLive (emit g)

gFix g@(RETURN) = ifLive (emit g)
gFix g@(RETURN_EVAL) = ifLive (emit g)

-- Heap
gFix g@(HEAP_INT  i) =   ifLive $ 
  if i >= -10 && i < 256 then
    emit g
  else
    addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
    emit (HEAP_CADR i)
gFix g@(HEAP_CHAR  i) =   ifLive $ 
  if i >= -1 && i < 256 then
    emit g
  else
    addBefore [DATA_CONW 1 0,DATA_W i] >>>= \ i ->
    emit (HEAP_CADR i)
gFix g@(HEAP_INTEGER  i) = ifLive $
    addBefore (lowInteger i) >>>= \ i ->
    emit (HEAP_CADR i)    
gFix g@(HEAP_FLOAT f) =  ifLive $
    addBefore [DATA_CONW 1 0,DATA_F f] >>>= \ i ->
    emit (HEAP_CADR i)
gFix g@(HEAP_DOUBLE d) =  ifLive $
    addDouble [DATA_CONW 2 0,DATA_D d,DATA_NOP] >>>= \ i ->
    emit (HEAP_CADR i)
gFix g@(HEAP_STRING s) =  ifLive $
    addString s [] >>>= \ label ->
    addBefore [DATA_GLB string label] >>>= \ i ->
    emit (HEAP_CVAL i)
gFix g@(HEAP_ARG  i) = ifLive (emit g)
gFix g@(HEAP_ARG_ARG i j) = ifLive (emit g)
gFix g@(HEAP_ARG_ARG_RET_EVAL i j) = ifLive (emit g)
gFix g@(HEAP      i) = ifLive (emit g)
gFix g@(HEAP_GLB s i) = ifLive $
    addAfter (DATA_GLB s i) >>>= \ i ->
    emit (HEAP_CVAL i)
gFix g@(HEAP_VAP  i) = ifLive $
    addAfter (DATA_VAP i) >>>= \ i ->
    emits [HEAP_CVAL i]
gFix g@(HEAP_CON  i) = ifLive $
    conInfo (toEnum i) >>>= \ (s,c) ->
    addBefore [DATA_CON s c] >>>= \ i ->
    emits [HEAP_CVAL i]
gFix g@(HEAP_CAP  i a) = ifLive $
    addAfter (DATA_CAP i a) >>>= \ i ->
    emits [HEAP_CVAL i] 
gFix g@(HEAP_OFF  i) = ifLive (emit g)
gFix g@(HEAP_STATIC p c) =
    addStatic p c >>>= \ label ->
    addBefore [DATA_GLB profstatic label] >>>= \ i ->
    emit (HEAP_CVAL i)
gFix g@(HEAP_CREATE) = ifLive (emit g)
gFix g@(HEAP_SPACE) = ifLive (emit g)
gFix g@(EVALUATED) = ifLive (emit g)

gFix g =
    gState >>>= \ state ->  error ("gFix:" ++ strGcode state g)



Bell Labs OSI certified Powered by Plan 9

(Return to Plan 9 Home Page)

Copyright © 2021 Plan 9 Foundation. All Rights Reserved.
Comments to webmaster@9p.io.